diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,6 @@ +# Changelog for newhope + +2019-03-?? Initial release + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,206 @@ +This library was written by Jeremy Bornstein and is licensed under the +Apache License, version 2.0. The full text of the license is +reproduced below. + + + + 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: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) 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 + + (d) 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 + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,40 @@ +This is a Haskell implementation of the [NewHope key exchange +protocol](https://newhopecrypto.org/). It has been made via +examination of the official NewHope project's [public domain C +reference code](https://github.com/newhopecrypto/newhope) and the +author is not affiliated with that team or with NIST. + +This codebase has not yet been reviewed by anyone other than the +author. Until such time as it has been competently reviewed, please +consider it as a draft implementation only, and do not rely on it for +actual securtiy in practice. Judged by comparison with the reference +library, it does produce correct results but could contain subtle (or +obvious!) flaws. In addition, it has not been optimized for +performance and at this stage is probably quite a bit slower than the +reference C implementation on any given platform. + +This project uses the Haskell build manager "stack" to produceː + + * `Crypto.NewHope`, a library intended for general use. + + * `PQCgenKAT` -- a binary which generates KAT (Known Answer Test) + files in the format required by the NIST PQC project. Invoke this + binary with the single argument "all" to generate all of the KAT + files. + + * `speed` -- a binary which runs performance tests of some of the + NewHope functionality. These tests correspond to largely equivalent + tests in the reference NewHope C code. + +In addition, the project contains a fair number of +automatically-evaluated tests that cover a large swath of the important +functionality implemented, including that tested by the "test" +binaries built by the reference C source, and including comparison +between the KAT output that we produce and that produced by the +reference C implementation. To run the tests and view the results, +execute `stack test` at a command line. + +लोकाः समस्ताः सुखिनोभवंतु + +Patches, comments, and discussion are welcome. The most appropriate +place for these for the time being is probably the Github repository. diff --git a/app/kat/PQCgenKAT.hs b/app/kat/PQCgenKAT.hs new file mode 100644 --- /dev/null +++ b/app/kat/PQCgenKAT.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE Safe #-} +{-| + Module : PQCgenKAT + Description : Generate files for Known Answer Tests + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + PQCgenKAT means: + Post Quantum Cryptography generate Known Answer Tests + + This generates test vectors (according to the NIST PQC spec) which + should be identical (in filenames and contents) to the ones generated + by the NewHope project's reference code. + + Automated tests elsewhere in this codebase which take those + reference implementation vectors as input to verify that we generate + the same data with the present implementation. + +-} + +module Main where + +import Control.Monad +import Data.ByteString.Lazy.Builder (hPutBuilder) +import Data.Text as Text (pack) +import Filesystem (IOMode (WriteMode), isFile, removeFile, withTextFile) +import Filesystem.Path.CurrentOS (fromText) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), exitWith) + +import qualified Crypto.NewHope as NewHope (N (N1024, N512)) +import qualified KAT + + +outputTestVectors :: NewHope.N -> Int -> KAT.VectorGenerator -> IO () +outputTestVectors n count gen = do + let (fileName, vectors) = gen n count + let filePath = fromText . pack $ fileName -- here's where we put it in some specific directory if we like + fileExists <- isFile filePath + when fileExists $ removeFile filePath + withTextFile filePath WriteMode $ \ handle -> hPutBuilder handle vectors + + +outputCcaVectors :: NewHope.N -> IO () +outputCcaVectors n = outputTestVectors n KAT.recordsToGenerate KAT.ccaKemTestVectors + +outputCpaVectors :: NewHope.N -> IO () +outputCpaVectors n = outputTestVectors n KAT.recordsToGenerate KAT.cpaKemTestVectors + + +main :: IO () +main = do + args <- getArgs + runCommand args + where + runCommand ["all"] = do outputCcaVectors NewHope.N512 + outputCcaVectors NewHope.N1024 + outputCpaVectors NewHope.N512 + outputCpaVectors NewHope.N1024 + + runCommand ["cca", "512"] = outputCcaVectors NewHope.N512 + runCommand ["cca", "1024"] = outputCcaVectors NewHope.N1024 + runCommand ["cpa", "512"] = outputCpaVectors NewHope.N512 + runCommand ["cpa", "1024"] = outputCpaVectors NewHope.N1024 + + runCommand _ = do + putStrLn "Required arguments: ([ cca | cpa ] [ 512 | 1024 ]) | all" + exitWith $ ExitFailure 1 diff --git a/app/libtest/LibTest.hs b/app/libtest/LibTest.hs new file mode 100644 --- /dev/null +++ b/app/libtest/LibTest.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : LibTest + Description : Testing code for the Crypto.NewHope library + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Main where + +import Test.Tasty + +import qualified Crypto.NewHope.Test.CCA_KEM as CCA_KEM +import qualified Crypto.NewHope.Test.CPA_KEM as CPA_KEM +import qualified Crypto.NewHope.Test.FIPS202 as FIPS202 +import qualified Crypto.NewHope.Test.NTT as NTT +import qualified Crypto.NewHope.Test.Poly as Poly +import qualified Crypto.NewHope.Test.Reduce as Reduce +import qualified Crypto.NewHope.Test.RNG as RNG +import qualified Crypto.NewHope.Test.SeedExpander as SeedExpander +import qualified Crypto.NewHope.Test.Verify as Verify +import qualified Test.ConfigFile as ConfigFile +import qualified Test.KAT as KAT + + + +main :: IO () +main = do + reduceTests <- Reduce.tests + rngTests <- RNG.tests + katTests <- KAT.tests + ccakemTests <- CCA_KEM.tests + nttTests <- NTT.tests + fips202Tests <- FIPS202.tests + polyTests <- Poly.tests + seedExpanderTests <- SeedExpander.tests + + defaultMain (testGroup "NewHope Library Tests" [ ConfigFile.tests + , Verify.tests + , reduceTests + , fips202Tests + , polyTests + , rngTests + , nttTests + , seedExpanderTests + , CPA_KEM.tests + , ccakemTests + , katTests + ]) + + return () diff --git a/app/speed/Speed.hs b/app/speed/Speed.hs new file mode 100644 --- /dev/null +++ b/app/speed/Speed.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Speed + Description : Speed tests for NewHope. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Mirrors the functionality provided by the speed_* binaries in the + reference C library. These are not part of our automated test suite + per se because they don't result in pass/fail: just speed numbers. + + Because Haskell is non-strict, we have to be careful about how we do + timing. I'm no expert, but evidence seems to indicate that the + approach taken here is effective for the circumstances: we force + evaluation of function arguments (with `deepseq` and associated + NFData instances) before the function itself is called. The + function "timingAssumptionsValid" should evaluate to IO True only + if we can trust our assumptions about how the system works, and it + is called before the tests proper start. + +-} + +module Main where + +import Control.DeepSeq +import qualified Data.ByteString as BS +import Data.List hiding (sum) +import qualified Data.Vector.Unboxed as VU +import System.CPUTime + +import AuxUtil +import qualified Crypto.NewHope as NewHope +import qualified Crypto.NewHope.Internal.CCA_KEM as CCA_KEM +import qualified Crypto.NewHope.Internal.CPA_KEM as CPA_KEM +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.Poly (Poly (..)) +import qualified Crypto.NewHope.Poly as Poly hiding (Poly) +import qualified Crypto.NewHope.RNG as RNG +import Timing + +-- | We use Null as the value of `deepseq` when we don't care about +-- the type of a prerequisite but still want to deepseq it. +data Null = Null deriving Show + +-- | This instance lets us deepseq, which we need to control execution order during tests. +instance NFData Null + where + rnf _sk = () + + +testCount :: Int +testCount = 1000 + + +median :: [Picoseconds] -> Picoseconds +median ns = ns' !! middle + where + ns' = sort ns + middle = Prelude.length ns `div` 2 + +mean :: [Picoseconds] -> Picoseconds +mean ns = total `div` items + where + total = sum ns + items = fromIntegral $ length ns + + +summarize :: String -> NewHope.N -> [Picoseconds] -> IO () +summarize name n values = putStrLn $ name ++ " (N=" ++ show (WrapN n) ++ "): " ++ timingStr + where + timingStr + | meanMilliseconds > 1 = ": mean " ++ show meanMilliseconds ++ "ms; median: " ++ show medianMilliseconds ++ "ms" + | meanMicroseconds > 1 = ": mean " ++ show meanMicroseconds ++ "μs; median: " ++ show medianMicroseconds ++ "μs" + | meanFemtoseconds > 1 = ": mean " ++ show meanFemtoseconds ++ "fs; median: " ++ show medianFemtoseconds ++ "fs" + | otherwise = ": mean " ++ show meanPicoseconds ++ "ps; median: " ++ show medianPicoseconds ++ "ps" + + meanPicoseconds = mean values + medianPicoseconds = median values + + meanMilliseconds = milliseconds meanPicoseconds + medianMilliseconds = milliseconds medianPicoseconds + + meanMicroseconds = microseconds meanPicoseconds + medianMicroseconds = microseconds medianPicoseconds + + meanFemtoseconds = femtoseconds meanPicoseconds + medianFemtoseconds = femtoseconds medianPicoseconds + + +-- | A TimingPair is a list of computations, the first of each which +-- is a prerequisite for the second. This is used to help isolate the +-- functions which we wish to time. +type TimingPair a b = (a, b) + + +-- | Given a list of TimingPair, return a list of times that each item +-- in the corresponding pair takes to compute. The only reason we care +-- about the timing of the first item is to ensure ourselves that our +-- assumptions about how evaluation works are warranted. In most +-- cases we only want to use a wrapper around this function that +-- discards the first item of each pair. +timeEvaluationsAndPrereqs :: (NFData a, NFData b) => [TimingPair a b] -> IO [(Picoseconds, Picoseconds)] +timeEvaluationsAndPrereqs input = do + output <- mapM go input + -- we compute but ignore the first result for reasons detailed below + return $ tail output + where + go :: (NFData c, NFData d) => (c, d) -> IO (Picoseconds, Picoseconds) + go (c, d) = do + start <- getCPUTime + middle <- deepseq c getCPUTime + end <- deepseq d getCPUTime + return (middle - start, end - middle) + + +-- | Given a list of TimingPair, return a list of times that each +-- second item in the pair takes to evaluate, after evaluation of the +-- first. We require NFData so that we can call `deepseq` to force +-- evaluation to normal form (and thereby ensure that the value is +-- computed before we check the time). +-- +-- In cases where the jig itself is not being tested, we don't care +-- about the timing of the prerequisite, so this function discards it. +timeEvaluationsWithPrereqs :: (NFData a, NFData b) => [TimingPair a b] -> IO [Picoseconds] +timeEvaluationsWithPrereqs input = fmap snd <$> timeEvaluationsAndPrereqs input + + +-- | Given a list of computations, return a list of times that each +-- takes to evaluate. Can be used when the function to be tested +-- takes no arguments. We require NFData so that we can call +-- `deepseq` to force evaluation to normal form (and thereby ensure +-- that the value is computed before we check the time). +timeEvaluations :: NFData a => [a] -> IO [Picoseconds] +timeEvaluations input = do + output <- mapM go input + -- we compute but ignore the first result for reasons detailed below + return $ tail output + where + go :: NFData a => a -> IO Picoseconds + go p = do + start <- getCPUTime + end <- deepseq p getCPUTime + return $ end - start + + +-- | An automatic test to let us know (by evaluating to IO True) if we +-- can seemingly trust our assumptions about how values computed by +-- prerequisites are cached in practice. If this returns IO False, we +-- probably can't trust our timing methodology: in that case, +-- something may have changed at the platform level. Our test is that +-- on each of three iterations, the expensive-to-compute prerequisite +-- must take more than 20 times as long as the cheap-to-compute main +-- function. +timingAssumptionsValid :: IO Bool +timingAssumptionsValid = prerequisitesAreVastlyMoreExpensive $ compute 3 + where + prerequisitesAreVastlyMoreExpensive :: (NFData a, NFData b) => [TimingPair a b] -> IO Bool + prerequisitesAreVastlyMoreExpensive f = and <$> (fmap . fmap) check times + where + times = timeEvaluationsAndPrereqs f + check (a, b) = (fromIntegral b * 100) / fromIntegral a < (0.05 :: Float) + + -- a list of pairs of computations, the first of each of which + -- should be much slower than the second, which uses the results + -- of the first. + compute :: Int -> [TimingPair Int Int] + compute count = foldr go [] [0 .. count] + where + go a results = new : results + where + expensive = fact $ 1000000 + a -- takes time to compute. include 'a' so we avoid caching + new = (expensive, testfn a) + fact 0 = 1 + fact n = n * fact (n - 1) + testfn b = b + expensive -- fast, apart from time spent computing expensive + + +-- | An infinite list of Seeds +seeds :: [Internals.Seed] +seeds = fst <$> next ctx + where + ctx = let randomSeed = RNG.makeRandomSeed $ BS.pack [0 .. 47] + in RNG.randomBytesInit randomSeed Nothing 0 + next ctx_ = (seed, ctx_) : next ctx_' + where + (seedData, ctx_') = RNG.randomBytes ctx_ Internals.seedBytes + seed = Internals.makeSeed seedData + + +-- * test computations + + +-- | Time computation of Poly.ntt +testPolyNTT :: Int -> NewHope.N -> [Poly] +testPolyNTT count n = foldr go [start] [0 .. count] + where + start :: Poly + start = Poly $ VU.fromList [1 .. fromIntegral (Internals.value n)] + go _a [] = [] -- non-occurring pattern included to shut up the compiler + go _a results@(first : _rest) = nextResult : results + where + nextResult = Poly.ntt first + + +-- | Time computation of Poly.invntt +testPolyInvNTT :: Int -> NewHope.N -> [Poly] +testPolyInvNTT count n = foldr go [start] [0 .. count] + where + start :: Poly + start = Poly $ VU.fromList [1 .. fromIntegral (Internals.value n)] + go :: Int -> [Poly] -> [Poly] + go _a [] = [] -- non-occurring pattern included to shut up the compiler + go _a results@(first : _rest) = nextResult : results + where + nextResult = Poly.invntt first + + +-- | Time computation of Poly.uniform. Note that this differs from the +-- reference library's test of this function in that we use a +-- different seed for each call to uniform, in case the system +-- helpfully caches the result of that function call for us. The +-- reference library makes the exact same call n times, though there +-- is no likely risk of the result being cached in that case. +testPolyUniform :: Int -> NewHope.N -> [TimingPair Internals.Seed Poly] +testPolyUniform count n = foldr go [(head seeds, start)] $ take count $ drop 1 seeds + where + start :: Poly + start = Poly $ VU.fromList [1 .. fromIntegral (Internals.value n)] + go seed results = nextResult : results + where + nextResult = (seed, Poly.uniform n seed) + + +-- | Time computation of Poly.sample, using a unique Seed for each +-- invocation. +testPolySample :: Int -> NewHope.N -> [TimingPair Internals.Seed Poly] +testPolySample count n = foldr go [(head seeds, start)] $ take count $ drop 1 seeds + where + start :: Poly + start = Poly $ VU.fromList [1 .. fromIntegral (Internals.value n)] + go seed results = nextResult : results + where + nextResult = (seed, Poly.sample n seed 1) + + +-- | Time computation of CPA_KEM.keypair. Results are returned in two +-- TimingPair lists for use in subsequent tests. +testCPAKeypair :: Int -> NewHope.N -> ([TimingPair RNG.Context CPA_KEM.PublicKey], [TimingPair RNG.Context CPA_KEM.SecretKey]) +testCPAKeypair count n = (pks, sks) + where + (_finalCTX, pks, sks) = foldr go (initialCTX, [], []) [0 .. count] + seed = RNG.makeRandomSeed "Assise en tailleur face à l'écran, Nadine appuie" + initialCTX = RNG.randomBytesInit seed Nothing 0 + go _a (ctx, pkResults, skResults) = (ctx', nextPK' : pkResults, nextSK' : skResults) + where + (nextPK, nextSK, ctx') = CPA_KEM.keypair ctx n + nextPK' = (ctx, nextPK) + nextSK' = (ctx, nextSK) + + +-- | Time computation of CCA_KEM.keypair. Results are returned in two +-- TimingPair lists for use in subsequent tests. +testCCAKeypair :: Int -> NewHope.N -> ([TimingPair RNG.Context CCA_KEM.PublicKey], [TimingPair RNG.Context CCA_KEM.SecretKey]) +testCCAKeypair count n = (pks, sks) + where + (_finalCTX, pks, sks) = foldr go (initialCTX, [], []) [0 .. count] + seed = RNG.makeRandomSeed "Assise en tailleur face à l'écran, Nadine appuie" + initialCTX = RNG.randomBytesInit seed Nothing 0 + go _a (ctx, pkResults, skResults) = (ctx', nextPK' : pkResults, nextSK' : skResults) + where + (nextPK, nextSK, ctx') = CCA_KEM.keypair ctx n + nextPK' = (ctx, nextPK) + nextSK' = (ctx, nextSK) + + +-- | Time computation of CPA_KEM.encrypt. +testCPAEncrypt :: [CPA_KEM.PublicKey] -> [TimingPair Null CPA_KEM.CipherText] +testCPAEncrypt pks = snd $ foldr go (initialCTX, []) pks + where + seed = RNG.makeRandomSeed "Assise en tailleur face à l'écran, Nadine appuie" + initialCTX = RNG.randomBytesInit seed Nothing 0 + go pk (ctx, results) = (ctx', nextResult : results) + where + (ct, _ss, ctx') = CPA_KEM.encrypt ctx pk + prereq' = seq (ctx, pk) Null -- not worth the typing to expose this upwards; deepseq will take care of it + nextResult = (prereq', ct) + + +-- | Time computation of CCA_KEM.encrypt. +testCCAEncrypt :: [CCA_KEM.PublicKey] -> [TimingPair Null CCA_KEM.CipherText] +testCCAEncrypt pks = snd $ foldr go (initialCTX, []) pks + where + seed = RNG.makeRandomSeed "Assise en tailleur face à l'écran, Nadine appuie" + initialCTX = RNG.randomBytesInit seed Nothing 0 + go pk (ctx, results) = (ctx', nextResult : results) + where + (ct, _ss, ctx') = CCA_KEM.encrypt ctx pk + prereq' = seq (ctx, pk) Null -- not worth the typing to expose this upwards; deepseq will take care of it + nextResult = (prereq', ct) + + +-- | Time computation of CPA_KEM.decrypt. +testCPADecrypt :: [CPA_KEM.CipherText] -> [CPA_KEM.SecretKey] -> [TimingPair Null CPA_KEM.SharedSecret] +testCPADecrypt cts sks = foldr go [] $ zip cts sks + where + go (ct, sk) results = nextResult : results + where + prereq = seq (ct, sk) Null + ss = CPA_KEM.decrypt ct sk + nextResult = (prereq, ss) + + +-- | Time computation of CCA_KEM.decrypt. +testCCADecrypt :: [CCA_KEM.CipherText] -> [CCA_KEM.SecretKey] -> [TimingPair Null (Bool, CCA_KEM.SharedSecret)] +testCCADecrypt cts sks = foldr go [] $ zip cts sks + where + go :: (CCA_KEM.CipherText, CCA_KEM.SecretKey) -> [TimingPair Null (Bool, CCA_KEM.SharedSecret)] -> [TimingPair Null (Bool, CCA_KEM.SharedSecret)] + go (ct, sk) results = nextResult : results + where + prereq = seq (ct, sk) Null -- not worth the typing to expose this upwards; deepseq will take care of it + ss = CCA_KEM.decrypt ct sk + nextResult = (prereq, ss) + + +-- | For tests that involve multiple stages of data, this version does +-- all of the non-timed work first. The chunks are organized so that a +-- garbage collector could save some space in-between unrelated +-- sections. +testN :: NewHope.N -> IO () +testN n = do + putStrLn "" + putStrLn $ "*** Testing N = " ++ show (WrapN n) + + -- we add an extra test so that the first test will absorb any + -- effects associated with dynamic loading of code or other + -- subtleties that may apply. (In practice, the first test often + -- takes significantly longer, so it seems reasonable not to count + -- it.) + let testCount' = testCount + 1 + + polyNTTTimes <- timeEvaluations $ testPolyNTT testCount' n + summarize "Poly NTT" n polyNTTTimes + + polyInvNTTTimes <- timeEvaluations $ testPolyInvNTT testCount' n + summarize "Poly inverse NTT" n polyInvNTTTimes + + polyUniformTimes <- timeEvaluationsWithPrereqs $ testPolyUniform testCount' n + summarize "Poly uniform" n polyUniformTimes + + polySampleTimes <- timeEvaluationsWithPrereqs $ testPolySample testCount' n + summarize "Poly sample" n polySampleTimes + + + putStr "Staging CPA computations for tests..." + let (cpaPKs, cpaSKs) = testCPAKeypair testCount' n + let cpaCTs = testCPAEncrypt (snd <$> cpaPKs) + let cpaSSs = testCPADecrypt (snd <$> cpaCTs) (snd <$> cpaSKs) + putStrLn " Done." + + let cpaPKSKs = let go (pkPrereq, pk) (skPrereq, sk) = ((pkPrereq, skPrereq), (pk, sk)) + in zipWith go cpaPKs cpaSKs + + cpaKeypairTimes <- timeEvaluationsWithPrereqs cpaPKSKs + summarize "CPA_KEM.keypair" n cpaKeypairTimes + + cpaEncryptTimes <- timeEvaluationsWithPrereqs cpaCTs + summarize "CPA_KEM.encrypt" n cpaEncryptTimes + + cpaDecryptTimes <- timeEvaluationsWithPrereqs cpaSSs + summarize "CPA_KEM.decrypt" n cpaDecryptTimes + + --- + + putStr "Staging CCA computations for tests..." + let (ccaPKs, ccaSKs) = testCCAKeypair testCount' n + let ccaCTs = testCCAEncrypt (snd <$> ccaPKs) + let ccaSSs = testCCADecrypt (snd <$> ccaCTs) (snd <$> ccaSKs) + putStrLn " Done." + + let ccaPKSKs = let go (pkPrereq, pk) (skPrereq, sk) = ((pkPrereq, skPrereq), (pk, sk)) + in zipWith go ccaPKs ccaSKs + + ccaKeypairTimes <- timeEvaluationsWithPrereqs ccaPKSKs + summarize "CCA_KEM.keypair" n ccaKeypairTimes + + ccaEncryptTimes <- timeEvaluations ccaCTs + summarize "CCA_KEM.encrypt" n ccaEncryptTimes + + ccaDecryptTimes <- timeEvaluations ccaSSs + summarize "CCA_KEM.decrypt" n ccaDecryptTimes + + return () + + +main :: IO () +main = do + putStr "*** Validating assumptions about timing.... " + timingOK <- timingAssumptionsValid + if timingOK + then putStrLn "Validated." + else error "Not validated. Timing results are questionable." + + putStrLn "" + putStrLn $ "NOTE: Each named test in this run comprises " ++ show testCount ++ " individual test iterations." + putStrLn "" + + testN NewHope.N512 + testN NewHope.N1024 diff --git a/auxiliary/AuxUtil.hs b/auxiliary/AuxUtil.hs new file mode 100644 --- /dev/null +++ b/auxiliary/AuxUtil.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : AuxUtil + Description : Auxiliary utilities + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Auxiliary utilities, used by testing and app code. Placed here to + avoid duplication. + +-} +module AuxUtil where + +import Test.Tasty.QuickCheck (Arbitrary, arbitrary, frequency) + +import qualified Crypto.NewHope as NewHope + + +newtype WrapN = WrapN NewHope.N + +instance Show WrapN + where + show (WrapN NewHope.N512) = "NewHope512" + show (WrapN NewHope.N1024) = "NewHope1024" + +-- TODO: isn't there a more elegant way to do this? +instance Arbitrary WrapN + where + arbitrary = do + a <- frequency [ (1, return NewHope.N512) + , (1, return NewHope.N1024) + ] + return $ WrapN a diff --git a/auxiliary/KAT.hs b/auxiliary/KAT.hs new file mode 100644 --- /dev/null +++ b/auxiliary/KAT.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE Safe #-} +{-| + Module : KAT + Description : Known Answer Tests + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + KAT stands for Known Answer Test(s). The validity of an + implementation may be judged in part by its ability to produce the + correct output. + + This module generates test vectors (according to the NIST PQC spec) + which should be identical (in filenames and contents) to the ones + generated by the original NewHope reference code. + + The automated tests in this codebase contain tests which take those + reference implementation vectors as input to verify that we generate + the same data with the below code. + +-} + +module KAT where + +import qualified Data.ByteString as BS +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Char +import Data.Semigroup ((<>)) + +import AuxUtil +import qualified Crypto.NewHope as NewHope +import qualified Crypto.NewHope.Internal.CCA_KEM as CCA_KEM +import qualified Crypto.NewHope.Internal.CPA_KEM as CPA_KEM +import qualified Crypto.NewHope.Internal.RNG as RNG + +type Filename = String +type VectorGenerator = NewHope.N -> Int -> (Filename, Builder) + + +recordsToGenerate :: Int +recordsToGenerate = 100 + + + + + +-- | output ByteString as uppercase hex string representation +processBS :: BS.ByteString -> String +processBS bs = toUpper <$> (BSLC.unpack . toLazyByteString . byteStringHex) bs + + + + + +-- | Note that the seeds used are the same for both algorithms and both variants thereof. +getSeeds :: [RNG.RandomSeed] +getSeeds = go initialCTX + where + initialSeed = RNG.makeRandomSeed $ BS.pack [0 .. 47] + initialCTX = RNG.randomBytesInit initialSeed Nothing 256 + go ctx = newSeed : go nextCTX + where + (newSeed, nextCTX) = (RNG.makeRandomSeed seed', ctx') + where + (seed', ctx') = RNG.randomBytes ctx 48 + + +ccaKemTestVectors :: VectorGenerator +ccaKemTestVectors n count = (filename, start <> contents) + where + filename = "PQCkemKAT_" ++ show (CCA_KEM.secretKeyBytes n) ++ ".rsp" + start = lazyByteString . BSLC.pack $ "# " ++ show (WrapN n) ++ "-CCAKEM\n\n" + contents = foldr1 mappend $ outputRecord <$> Prelude.zip [0 ..] (take count getSeeds) + + outputRecord :: (Int, RNG.RandomSeed) -> Builder + outputRecord (i, seed) = header <> record + where + header = lazyByteString . BSLC.pack $ "count = " ++ show i ++ "\n" + record = testVectorsFromSeed seed + + testVectorsFromSeed :: RNG.RandomSeed -> Builder + testVectorsFromSeed seed = seq check output' + where + ctx = RNG.randomBytesInit seed Nothing 256 + (pk, sk, ctx') = CCA_KEM.keypair ctx n + (ct, ss, _) = CCA_KEM.encrypt ctx' pk + check = let (success, ss') = CCA_KEM.decrypt ct sk + ssOK = success && ss == ss' + in if not ssOK + then error "Shared secret could not be generated." + else () + + seedData = RNG.getRandomSeedData seed + output = (lazyByteString . BSLC.pack) <$> [ "seed = " ++ processBS seedData ++ "\n" + , "pk = " ++ processBS (CCA_KEM.getPKData pk) ++ "\n" + , "sk = " ++ processBS (CCA_KEM.getSKData sk) ++ "\n" + , "ct = " ++ processBS (CCA_KEM.getCTData ct) ++ "\n" + , "ss = " ++ processBS (CCA_KEM.getSSData ss) ++ "\n" + , "\n" + ] + output' = foldr go (byteString $ BSC.pack "") output + where + go a as = a <> as + + +cpaKemTestVectors :: VectorGenerator +cpaKemTestVectors n count = (filename, start <> contents) + where + filename = "PQCkemKAT_" ++ show (CPA_KEM.secretKeyBytes n) ++ ".rsp" + start = lazyByteString . BSLC.pack $ "# " ++ show (WrapN n) ++ "-CPAKEM\n\n" + contents = foldr1 mappend $ outputRecord <$> Prelude.zip [0 ..] (take count getSeeds) + + outputRecord :: (Int, RNG.RandomSeed) -> Builder + outputRecord (i, seed) = header <> record + where + header = lazyByteString . BSLC.pack $ "count = " ++ show i ++ "\n" + record = testVectorsFromSeed seed + + testVectorsFromSeed :: RNG.RandomSeed -> Builder + testVectorsFromSeed seed = seq check output' + where + ctx = RNG.randomBytesInit seed Nothing 256 + (pk, sk, ctx') = CPA_KEM.keypair ctx n + (ct, ss, _) = CPA_KEM.encrypt ctx' pk + check = let mss = CPA_KEM.decrypt ct sk + ssOK = ss == mss + in if not ssOK + then error "Shared secret could not be generated." + else () + + seedData = RNG.getRandomSeedData seed + output = (lazyByteString . BSLC.pack) <$> [ "seed = " ++ processBS seedData ++ "\n" + , "pk = " ++ processBS (CPA_KEM.getPKData pk) ++ "\n" + , "sk = " ++ processBS (CPA_KEM.getSKData sk) ++ "\n" + , "ct = " ++ processBS (CPA_KEM.getCTData ct) ++ "\n" + , "ss = " ++ processBS (CPA_KEM.getSSData ss) ++ "\n" + , "\n" + ] + output' = foldr go (byteString $ BSC.pack "") output + where + go a as = a <> as diff --git a/auxiliary/Timing.hs b/auxiliary/Timing.hs new file mode 100644 --- /dev/null +++ b/auxiliary/Timing.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Timing + Description : Timing utilities + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Timing where + + +type Picoseconds = Integer +type Milliseconds = Integer +type Microseconds = Integer +type Femtoseconds = Integer + +milliseconds :: Picoseconds -> Milliseconds +milliseconds p = p `div` 1000000000 + +microseconds :: Picoseconds -> Microseconds +microseconds p = p `div` 1000000 + +femtoseconds :: Picoseconds -> Femtoseconds +femtoseconds p = p `div` 1000 + + +showTime :: Picoseconds -> String +showTime picoseconds = result + where + result | asMilliseconds > 1 = show asMilliseconds ++ "ms" + | asMicroseconds > 1 = show asMicroseconds ++ "µs" + | asFemtoseconds > 1 = show asFemtoseconds ++ "fs" + | otherwise = show picoseconds ++ "ps" + + asMilliseconds = milliseconds picoseconds + asMicroseconds = microseconds picoseconds + asFemtoseconds = femtoseconds picoseconds diff --git a/newhope.cabal b/newhope.cabal new file mode 100644 --- /dev/null +++ b/newhope.cabal @@ -0,0 +1,221 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: fc69f9cd0d25496be7de02d53407ea306132435af206b38a738ccf3ba3f4274e + +name: newhope +version: 0.1.0.0 +synopsis: Library implementing the NewHope cryptographic key-exchange protocol +description: This is a Haskell implementation of the NewHope key exchange protocol. It has been made via examination of the official NewHope project's public domain C reference code and the author is not affiliated with that team or with NIST. For further details please see the package README. +category: Library, Cryptography +homepage: https://github.com/unprolix/newhope#README.md +bug-reports: https://github.com/unprolix/newhope/issues +author: Jeremy Bornstein +maintainer: jeremy@bornstein.org +copyright: © 2019 Jeremy Bornstein +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/https://github.com/unprolix/newhope + +library + exposed-modules: + Crypto.NewHope + Crypto.NewHope.CCA_KEM + Crypto.NewHope.CPA_KEM + Crypto.NewHope.RNG + Crypto.NewHope.SeedExpander + other-modules: + Crypto.NewHope.CPA_PKE + Crypto.NewHope.FIPS202 + Crypto.NewHope.Internal.CCA_KEM + Crypto.NewHope.Internal.CPA_KEM + Crypto.NewHope.Internal.RNG + Crypto.NewHope.Internal.SeedExpander + Crypto.NewHope.Internals + Crypto.NewHope.NTT + Crypto.NewHope.Poly + Crypto.NewHope.Precomp + Crypto.NewHope.Reduce + Crypto.NewHope.Verify + MiscUtils + StringUtils + Paths_newhope + hs-source-dirs: + src + ghc-options: -Wall -O2 + build-depends: + AES >=0.2 && <0.3 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.7 + , deepseq >=1.4 && <1.5 + , mtl >=2.2 && <2.3 + , vector >=0.12 && <0.13 + default-language: Haskell2010 + +executable PQCgenKAT + main-is: PQCgenKAT.hs + other-modules: + AuxUtil + KAT + Timing + Crypto.NewHope + Crypto.NewHope.CCA_KEM + Crypto.NewHope.CPA_KEM + Crypto.NewHope.CPA_PKE + Crypto.NewHope.FIPS202 + Crypto.NewHope.Internal.CCA_KEM + Crypto.NewHope.Internal.CPA_KEM + Crypto.NewHope.Internal.RNG + Crypto.NewHope.Internal.SeedExpander + Crypto.NewHope.Internals + Crypto.NewHope.NTT + Crypto.NewHope.Poly + Crypto.NewHope.Precomp + Crypto.NewHope.Reduce + Crypto.NewHope.RNG + Crypto.NewHope.SeedExpander + Crypto.NewHope.Verify + MiscUtils + StringUtils + Paths_newhope + hs-source-dirs: + app/kat + auxiliary + src + ghc-options: -Wall -O2 -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: + AES + , base >=4.7 && <5 + , bytestring + , containers + , deepseq + , mtl + , system-fileio >=0.3 && <90.4 + , system-filepath >=0.4 && <0.5 + , tasty-quickcheck >=0.10 && <0.11 + , text >=1.2 && <1.3 + , vector + default-language: Haskell2010 + +executable speed + main-is: Speed.hs + other-modules: + AuxUtil + KAT + Timing + Crypto.NewHope + Crypto.NewHope.CCA_KEM + Crypto.NewHope.CPA_KEM + Crypto.NewHope.CPA_PKE + Crypto.NewHope.FIPS202 + Crypto.NewHope.Internal.CCA_KEM + Crypto.NewHope.Internal.CPA_KEM + Crypto.NewHope.Internal.RNG + Crypto.NewHope.Internal.SeedExpander + Crypto.NewHope.Internals + Crypto.NewHope.NTT + Crypto.NewHope.Poly + Crypto.NewHope.Precomp + Crypto.NewHope.Reduce + Crypto.NewHope.RNG + Crypto.NewHope.SeedExpander + Crypto.NewHope.Verify + MiscUtils + StringUtils + Paths_newhope + hs-source-dirs: + app/speed + auxiliary + src + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: + AES + , base >=4.7 && <5 + , bytestring + , containers + , deepseq + , mtl + , tasty-quickcheck + , vector + default-language: Haskell2010 + +test-suite libtest + type: exitcode-stdio-1.0 + main-is: LibTest.hs + other-modules: + AuxUtil + KAT + Timing + Crypto.NewHope + Crypto.NewHope.CCA_KEM + Crypto.NewHope.CPA_KEM + Crypto.NewHope.CPA_PKE + Crypto.NewHope.FIPS202 + Crypto.NewHope.Internal.CCA_KEM + Crypto.NewHope.Internal.CPA_KEM + Crypto.NewHope.Internal.RNG + Crypto.NewHope.Internal.SeedExpander + Crypto.NewHope.Internals + Crypto.NewHope.NTT + Crypto.NewHope.Poly + Crypto.NewHope.Precomp + Crypto.NewHope.Reduce + Crypto.NewHope.RNG + Crypto.NewHope.SeedExpander + Crypto.NewHope.Verify + MiscUtils + StringUtils + ConfigFile + Crypto.NewHope.Test.CCA_KEM + Crypto.NewHope.Test.CPA_KEM + Crypto.NewHope.Test.FIPS202 + Crypto.NewHope.Test.NTT + Crypto.NewHope.Test.Poly + Crypto.NewHope.Test.Reduce + Crypto.NewHope.Test.RNG + Crypto.NewHope.Test.SeedExpander + Crypto.NewHope.Test.Verify + Statistics + Test.ConfigFile + Test.KAT + Util + Paths_newhope + hs-source-dirs: + app/libtest + auxiliary + src + test + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: + AES + , HUnit >=1.6 && <1.7 + , QuickCheck >=2.11 && <2.13 + , base >=4.7 && <5 + , bytestring + , containers + , deepseq + , hspec >=2.5 && <2.7 + , mtl + , parallel >=3.2 && <3.3 + , raw-strings-qq >=1.1 && <1.2 + , statistics >=0.14 && <0.16 + , system-fileio + , system-filepath + , tasty >=1.1 && <1.3 + , tasty-expected-failure >=0.11 && <0.12 + , tasty-hunit >=0.10 && <0.11 + , tasty-quickcheck + , text + , trifecta >=2 && <2.0 + , vector + default-language: Haskell2010 diff --git a/src/Crypto/NewHope.hs b/src/Crypto/NewHope.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope + Description : NewHope cryptographic key-exchange protocol library + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + This is the main (and very sparse) public module for the NewHope + cryptography library. In order to perform useful operations, you + will probably also wish to import "Crypto.NewHope.CPA_KEM" and/or + "Crypto.NewHope.CCA_KEM", which each implement keypair generation, + encryption, and decryption (see those modules for sample usage of + these components to effect an actual key exchange). Also required + for import will be "Crypto.NewHope.RNG" for generation of a + 'Context' for pseudorandom number generation, used in the key + exchange protocol. + + You may also import the "Crypto.NewHope.SeedExpander" module to use + the seedexpander functionality, which is not otherwise necessary for + the key exchange protocol but which is provided here because it is + part of the NIST spec and the reference library. + + Naming of exported symbols is largely consistent with that used in + the reference implementation, and therefore strongly related to the + specifications required by the NIST PQC project. However changes + have been made to naming where they seem to make sense, e.g. instead + of the function crypto_kem_enc() being defined twice, once each for + the IND-CPA-secure and the IND-CCA-secure variants, here we define + the function 'encrypt' as appropriate in "Crypto.NewHope.CCA_KEM" + and also in "Crypto.NewHope.CPA_KEM". If you are familiar with the + reference C implementation none of these changes should be + surprising. + +-} + +module Crypto.NewHope ( N(N512, N1024) + ) where + +import Crypto.NewHope.Internals (N (N1024, N512)) diff --git a/src/Crypto/NewHope/CCA_KEM.hs b/src/Crypto/NewHope/CCA_KEM.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/CCA_KEM.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.CCA_KEM + Description : IND-CCA-secure operations for the NewHope key exchange protocol + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + IND-CCA-secure operations for the NewHope key exchange protocol. The + algorithm name is either NewHope512-CCAKEM or NewHope1024-CCAKEM, + depending on the value of 'N'. + + This module contains the public interface. Implementation definitions + are in the "Crypto.NewHope.Internal.CCA_KEM" module. + + * Sample usage + + @ + -- Alice initiates the exchange + seedA = makeRandomSeed fortyEightBytesOfEntropyA -- Seed the pseudorandom number generator (Alice's side) + ctxA = randomBytesInit seedA Nothing 256 -- Source of pseudorandomness + (pk, skA, ctxA') = keypair ctxA N1024 -- Alice generates a public key and her secret key + + -- [Alice sends the public key to Bob] + + -- Bob uses the public key to derive the shared secret along with data to send to Alice + seedB = makeRandomSeed fortyEightBytesOfEntropyB -- Seed the pseudorandom number generator (Bob's side) + ctxB = randomBytesInit seedB Nothing 256 -- Source of pseudorandomness + (sendb, keyB, ctxB') = encrypt ctxB pk -- Bob derives a secret key and creates a response + + -- [Bob sends sendb back to Alice] + + keyA = decrypt sendb skA -- Alice derives her copy of the shared secret + @ + +-} + +module Crypto.NewHope.CCA_KEM ( keypair + , encrypt + , decrypt + + ) where + + +import Crypto.NewHope.Internal.CCA_KEM diff --git a/src/Crypto/NewHope/CPA_KEM.hs b/src/Crypto/NewHope/CPA_KEM.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/CPA_KEM.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.CPA_KEM + Description : IND-CPA-secure operations for the NewHope key exchange protocol + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + IND-CPA-secure operations for the NewHope key exchange protocol. The + algorithm name is either NewHope512-CPAKEM or NewHope1024-CPAKEM, + depending on the value of 'N'. + + This module contains the public interface. Implementation definitions + are in the "Crypto.NewHope.Internal.CPA_KEM" module. + + * Sample usage + + @ + -- Alice initiates the exchange + seedA = makeRandomSeed fortyEightBytesOfEntropyA -- Seed the pseudorandom number generator (Alice's side) + ctxA = randomBytesInit seedA Nothing 256 -- Source of pseudorandomness + (pk, skA, ctxA') = keypair ctxA N1024 -- Alice generates a public key and her secret key + + -- [Alice sends the public key to Bob] + + -- Bob uses the public key to derive the shared secret along with data to send to Alice + seedB = makeRandomSeed fortyEightBytesOfEntropyB -- Seed the pseudorandom number generator (Bob's side) + ctxB = randomBytesInit seedB Nothing 256 -- Source of pseudorandomness + (sendb, keyB, ctxB') = encrypt ctxB pk -- Bob derives a secret key and creates a response + + -- [Bob sends sendb back to Alice] + + keyA = decrypt sendb skA -- Alice derives her copy of the shared secret + @ + +-} + +module Crypto.NewHope.CPA_KEM ( keypair + , encrypt + , decrypt + ) where + +import Crypto.NewHope.Internal.CPA_KEM diff --git a/src/Crypto/NewHope/CPA_PKE.hs b/src/Crypto/NewHope/CPA_PKE.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/CPA_PKE.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.CPA_PKE + Description : IND-CPA-secure key encapsulation for the NewHope key exchange protocol + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + IND-CPA-secure key encapsulation for the NewHope key exchange protocol + +-} + +module Crypto.NewHope.CPA_PKE ( keypair + , encrypt + , decrypt + + , publicKeyBytes + , secretKeyBytes + , cipherTextBytes + + , PublicKey + , makePublicKey + , makePublicKeyFromBytes + , getPKData + , getPKPolyData + , getPKPoly + , getPKSeed + + , SecretKey + , makeSecretKey + , makeSecretKeyFromBytes + , getSKPoly + , getSKPolyData + + , CipherText + , makeCipherTextFromBytes -- need to do this when decrypting + , getCTData + , getCTb + , getCTbData + , getCTv + + , makePlainText -- we use Plain instead of Clear so we have distinct abbreviations! i.e. pt != ct + , getPTData + ) where + +import Control.Applicative +import qualified Data.ByteString as BS + +import Crypto.NewHope.FIPS202 +import Crypto.NewHope.Internals (N (N1024, N512), symBytes) +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.Poly (Poly) +import qualified Crypto.NewHope.Poly as Poly +import Crypto.NewHope.RNG +import StringUtils + + +-- * Counting bytes + +-- | Size in bytes of a PublicKey +publicKeyBytes :: Internals.N -> Int +publicKeyBytes n = Poly.polyBytes n + symBytes + +-- | Size in bytes of a SecretKey +secretKeyBytes :: Internals.N -> Int +secretKeyBytes = Poly.polyBytes + +-- | Size in bytes of a CipherText +cipherTextBytes :: Internals.N -> Int +cipherTextBytes = liftA2 (+) Poly.polyBytes Poly.polyCompressedBytes + + +-- * PlainText + +-- | This is a "msg" encoded from a Poly. Since these are of constant +-- length even for different N, when restoring the Poly we need to +-- know N from elsewhere. +newtype PlainText = PlainText BS.ByteString deriving Eq + +-- | Construct PlainText from ByteString +makePlainText :: BS.ByteString -> PlainText +makePlainText bs + | not lengthOK = error "Invalid length for PlainText" + | otherwise = PlainText bs + where + len = BS.length bs + lengthOK = len == Poly.polyMsgBytes + + +-- | The raw data inside a PlainText +getPTData :: PlainText -> BS.ByteString +getPTData (PlainText ptData) = ptData + + +-- | The encoded Poly inside a PlainText +getPTv :: PlainText -> Internals.N -> Poly +getPTv (PlainText ptData) n = Poly.fromMsg n ptData + + + +-- * PublicKey + +newtype PublicKey = PublicKey BS.ByteString deriving Eq + + +-- | The N associated with this key +getPKn :: PublicKey -> Internals.N +getPKn (PublicKey pkData) + | len == publicKeyBytes N512 = N512 + | len == publicKeyBytes N1024 = N1024 + | otherwise = error "Invalid N for PublicKey" + where + len = BS.length pkData + + +-- | In terms of the NewHope protocol, our PublicKey data is a +-- concatenation of the serialization of the Poly pk and the +-- public seed which generated the Poly a. +makePublicKey :: Poly -> Internals.Seed -> PublicKey +makePublicKey poly seed + | not lengthOK = error "Invalid imputed length for PublicKey" + | otherwise = PublicKey bs + where + bs = BS.append poly' seed' + poly' = Poly.toByteString poly + seed' = Internals.getSeedData seed + n = Poly.getN poly + lengthOK = BS.length bs == publicKeyBytes n + + +-- | Construct PublicKey from ByteString +makePublicKeyFromBytes :: BS.ByteString -> PublicKey +makePublicKeyFromBytes pkData + | not lengthOK = error "Invalid length for PublicKey" + | otherwise = PublicKey pkData + where + len = BS.length pkData + lengthOK = len == publicKeyBytes N512 || len == publicKeyBytes N1024 + + +-- | The raw data inside a PublicKey +getPKData :: PublicKey -> BS.ByteString +getPKData (PublicKey pkData) = pkData + + +-- | The length of the encoded Poly pk in our encoded data. +getPKPolyBytes :: PublicKey -> Int +getPKPolyBytes pk = Poly.polyBytes $ getPKn pk + + +-- | The raw data encoding the Poly pk +getPKPolyData :: PublicKey -> BS.ByteString +getPKPolyData pk@(PublicKey pkData) = encoded + where + polyBytes = getPKPolyBytes pk + encoded = BS.take polyBytes pkData + + +-- | The decoded Poly pk +getPKPoly :: PublicKey -> Poly +getPKPoly pk@(PublicKey pkData) = Poly.fromByteString encoded + where + polyBytes = getPKPolyBytes pk + encoded = BS.take polyBytes pkData + + +-- | The Seed +getPKSeed :: PublicKey -> Internals.Seed +getPKSeed (PublicKey pkData) = Internals.makeSeed seedData + where + offset = BS.length pkData - symBytes + seedData = BS.drop offset pkData + + + +-- * SecretKey + +newtype SecretKey = SecretKey BS.ByteString deriving Eq + +-- | Construct from a Poly +makeSecretKey :: Poly -> SecretKey +makeSecretKey poly + | not lengthOK = error "Invalid imputed N for SecretKey" + | otherwise = SecretKey bs + where + n = Poly.getN poly + bs = Poly.toByteString poly + lengthOK = BS.length bs == secretKeyBytes n + + +-- | Construct from a ByteString, which must contain a serialized Poly. +makeSecretKeyFromBytes :: BS.ByteString -> SecretKey +makeSecretKeyFromBytes bs + | not lengthOK = error "Invalid length for SecretKey" + | otherwise = SecretKey bs + where + len512 = secretKeyBytes N512 + len1024 = secretKeyBytes N1024 + len = BS.length bs + lengthOK = len == len512 || len == len1024 + + +-- | The N associated with this key. Prefixed with _ because nothing +-- uses this now, but it's good to have it here to document the +-- structure/contents and for possible future testing. +_getSKn :: SecretKey -> Internals.N +_getSKn (SecretKey skData) + | len == len512 = N512 + | len == len1024 = N1024 + | otherwise = error "Invalid N for SecretKey" + where + len = BS.length skData + len512 = secretKeyBytes N512 + len1024 = secretKeyBytes N1024 + + +-- | The encoded Poly data, which also happens to be all of our data +getSKPolyData :: SecretKey -> BS.ByteString +getSKPolyData (SecretKey sk) = sk + + +-- | The encapsulated Poly +getSKPoly :: SecretKey -> Poly +getSKPoly (SecretKey sk) = Poly.fromByteString sk + + + +-- * CipherText + +newtype CipherText = CipherText BS.ByteString deriving Eq + +-- TDOD: Useful for debugging. Should we retain it in the distribution? +instance Show CipherText where + show (CipherText bs) = "CipherText: " ++ byteStringToHexString bs + + +-- | Construct a CipherText from two Polys. +makeCipherText :: Poly -> Poly -> CipherText +makeCipherText b v + | not lengthOK = error "Invalid imputed length for CipherText" + | otherwise = CipherText bs + where + b' = Poly.toByteString b + v' = Poly.compress v + bs = BS.append b' v' + + lengthOK = let bn = Poly.getN b + vn = Poly.getN v + in (bn == vn) && (BS.length bs == cipherTextBytes bn) + + +-- | Construct a CipherText from the data in a ByteString +makeCipherTextFromBytes :: BS.ByteString -> CipherText +makeCipherTextFromBytes bs + | not lengthOK = error "Invalid length for CipherText" + | otherwise = CipherText bs + where + len = BS.length bs + len512 = cipherTextBytes N512 + len1024 = cipherTextBytes N1024 + lengthOK = len == len512 || len == len1024 + + +-- | The N associated with this CipherText +getCTn :: CipherText -> Internals.N +getCTn (CipherText ctData) + | len == len512 = N512 + | len == len1024 = N1024 + | otherwise = error "Invalid N for CipherText" + where + len = BS.length ctData + len512 = cipherTextBytes N512 + len1024 = cipherTextBytes N1024 + + +-- | The data encoding the encapsulated Poly b +getCTbData :: CipherText -> BS.ByteString +getCTbData ct@(CipherText ctData) = polyData + where + polyData = BS.take polyBytes ctData + n = getCTn ct + polyBytes = Poly.polyBytes n + + +-- | The encapsulated Poly b +getCTb :: CipherText -> Poly +getCTb = Poly.fromByteString . getCTbData + + +-- | The data encoding the encapsulated Poly v +getCTData :: CipherText -> BS.ByteString +getCTData (CipherText ctData) = ctData + + +-- | The encapsulated Poly v +getCTv :: CipherText -> Poly +getCTv ct@(CipherText ctData) = Poly.decompress polyData + where + polyData = BS.drop polyBytes ctData + n = getCTn ct + polyBytes = Poly.polyBytes n + + +-- | Deterministically generate public Poly a from Seed. This is just +-- `Poly.uniform` but remains here for some degree of isomorphism with +-- the reference library. +genA :: Internals.N -> Internals.Seed -> Poly +genA = Poly.uniform + + + +-- * Higher-level functions + + +-- | Generates a new keypair, along with the post-utilization Context. +keypair :: Context -> Internals.N -> (PublicKey, SecretKey, Context) +keypair ctx n = (pk, sk, ctx') + where + (z, ctx') = randomBytes ctx symBytes + (publicSeed, noiseSeed) = BS.splitAt symBytes $ shake256 z (2 * symBytes) + + shat = Poly.ntt $ Poly.sample n (Internals.makeSeed noiseSeed) 0 + ehat = Poly.ntt $ Poly.sample n (Internals.makeSeed noiseSeed) 1 + + sk = makeSecretKey shat + + pk = let ahatShat = let ahat = genA n $ Internals.makeSeed publicSeed + in Poly.mulPointwise shat ahat + bhat = Poly.add ehat ahatShat + in makePublicKey bhat $ Internals.makeSeed publicSeed + + +-- | Encrypt PlainText to CipherText +encrypt :: PlainText -> PublicKey -> Internals.Seed -> CipherText +encrypt pt pk coin = makeCipherText uhat vprime + where + n = getPKn pk + v = getPTv pt n + + bhat = getPKPoly pk + publicSeed = getPKSeed pk + sprime = Poly.ntt $ Poly.sample n coin 0 + eprime = Poly.ntt $ Poly.sample n coin 1 + uhat = Poly.add eprime $ Poly.mulPointwise sprime (genA n publicSeed) + + vprime = Poly.add v $ Poly.add (Poly.sample n coin 2) + (Poly.invntt $ Poly.mulPointwise bhat sprime) + + +-- | Decrypt CipherText to PlainText. +decrypt :: CipherText -> SecretKey -> PlainText +decrypt c sk = PlainText msg + where + shat = getSKPoly sk + uhat = getCTb c + vprime = getCTv c + msg = Poly.toMsg $ Poly.sub (Poly.invntt $ Poly.mulPointwise shat uhat) vprime + diff --git a/src/Crypto/NewHope/FIPS202.hs b/src/Crypto/NewHope/FIPS202.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/FIPS202.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.FIPS202 + Description : Implements the FIPS202 (aka SHA-3) hashing algorithm. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Implements the FIPS202 (aka SHA-3) hashing algorithm. This version + is based on the version from the NewHope C reference implementation, + which in turn was based on the public domain implementation in + crypto_hash/keccakc512/simple/ from + http://bench.cr.yp.to/supercop.html by Ronny Van Keer, and the + public domain "TweetFips202" implementation from + https://twitter.com/tweetfips202 by Gilles Van Assche, Daniel + J. Bernstein, and Peter Schwabe. + + Note: When the author wrote this, he was unaware of the Keccak + package that already existed in Hackage, which may have significantly + differnent performance. It would not be a mistake to see if that + implementation has more desirable characteristics than this one. + +-} + +module Crypto.NewHope.FIPS202 where + +import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Data.Word +import Prelude hiding (round) + +import StringUtils + + +-- | Our basic data: unboxed vector of 64-bit integers +type KeccakVector = VU.Vector Word64 + +-- | Length of state vector +keccakStateLength :: Int +keccakStateLength = 25 + +-- | Size of blocks for SHAKE128 +shake128Rate :: Int +shake128Rate = 168 + +-- | Size of blocks for SHAKE256 +shake256Rate :: Int +shake256Rate = 136 + +-- | How many rounds of permutation should be performed +keccakF1600StatePermuteRoundsCount :: Int +keccakF1600StatePermuteRoundsCount = 24 + +-- | Starting point for computation +keccakEmpty :: KeccakVector +keccakEmpty = VU.replicate keccakStateLength 0 + + + + +keccakFRoundConstants :: KeccakVector +keccakFRoundConstants = VU.fromList [ 0x0000000000000001, 0x0000000000008082, 0x800000000000808a, 0x8000000080008000, + 0x000000000000808b, 0x0000000080000001, 0x8000000080008081, 0x8000000000008009, + 0x000000000000008a, 0x0000000000000088, 0x0000000080008009, 0x000000008000000a, + 0x000000008000808b, 0x800000000000008b, 0x8000000000008089, 0x8000000000008003, + 0x8000000000008002, 0x8000000000000080, 0x000000000000800a, 0x800000008000000a, + 0x8000000080008081, 0x8000000000008080, 0x0000000080000001, 0x8000000080008008] + + +rol :: Word64 -> Int -> Word64 +rol a offset = shift a offset `xor` shift a (offset - 64) + + +-- | Given 8 bytes from a ByteString, compute a Word64 containing those bytes in little-endian order +load64 :: BS.ByteString -- ^ Source data + -> Int -- ^ Offset within source from which to select data + -> Word64 +load64 input offset + | BS.length trimmed < 8 = error ("TOO SHORT: \"" ++ (byteStringToHexString trimmed :: String) ++ "\"") + | otherwise = foldl go a as + where + trimmed = BS.take 8 (BS.drop offset input) + a : as = reverse $ fromIntegral <$> BS.unpack trimmed + go d c = c .|. shift d 8 + + +-- | Given 8 bytes from an unboxed Vector of bytes, compute a Word64 containing those bytes in little-endian order +load64' :: VU.Vector Word8 -- ^ Source data + -> Int -- ^ Offset within source from which to select data + -> Word64 +load64' input offset = foldl go a as + where + a : as = reverse $ fmap fromIntegral $ VU.toList $ VU.take 8 (VU.drop offset input) + go d c = c .|. shift d 8 + + +-- | Given a Word64, compute a ByteString containing the same value in little-endian order +store64 :: Word64 -> BS.ByteString +store64 value = BS.pack $ fmap fromIntegral [ value .&. 0xFF, + shift value $ -8 .&. 0xFF, + shift value $ -16 .&. 0xFF, + shift value $ -24 .&. 0xFF, + shift value $ -32 .&. 0xFF, + shift value $ -40 .&. 0xFF, + shift value $ -48 .&. 0xFF, + shift value $ -56 .&. 0xFF] + +-- | Perform one round of permutation +keccakF1600StatePermute :: KeccakVector -> KeccakVector +keccakF1600StatePermute state' = runRounds state' 0 + where + runRounds state round = if round >= keccakF1600StatePermuteRoundsCount - 2 + then result + else runRounds result (round + 2) + where + aba = state VU.! 0 + abe = state VU.! 1 + abi = state VU.! 2 + abo = state VU.! 3 + abu = state VU.! 4 + aga = state VU.! 5 + age = state VU.! 6 + agi = state VU.! 7 + ago = state VU.! 8 + agu = state VU.! 9 + aka = state VU.! 10 + ake = state VU.! 11 + aki = state VU.! 12 + ako = state VU.! 13 + aku = state VU.! 14 + ama = state VU.! 15 + ame = state VU.! 16 + ami = state VU.! 17 + amo = state VU.! 18 + amu = state VU.! 19 + asa = state VU.! 20 + ase = state VU.! 21 + asi = state VU.! 22 + aso = state VU.! 23 + asu = state VU.! 24 + + -- prepareTheta + bca = aba `xor` aga `xor` aka `xor` ama `xor` asa + bce = abe `xor` age `xor` ake `xor` ame `xor` ase + bci = abi `xor` agi `xor` aki `xor` ami `xor` asi + bco = abo `xor` ago `xor` ako `xor` amo `xor` aso + bcu = abu `xor` agu `xor` aku `xor` amu `xor` asu + + -- thetaRhoPiChiIotaPrepareTheta(round , A, E) + da = bcu `xor` rol bce 1 + de = bca `xor` rol bci 1 + di = bce `xor` rol bco 1 + do1 = bci `xor` rol bcu 1 + du = bco `xor` rol bca 1 + + aba2 = aba `xor` da + + bca2 = aba2 + age2 = age `xor` de + bce2 = rol age2 44 + aki2 = aki `xor` di + bci2 = rol aki2 43 + amo2 = amo `xor` do1 + bco2 = rol amo2 21 + asu2 = asu `xor` du + bcu2 = rol asu2 14 + eba4 = bca2 `xor` complement bce2 .&. bci2 + eba5 = eba4 `xor` (keccakFRoundConstants VU.! round) + ebe = bce2 `xor` complement bci2 .&. bco2 + ebi = bci2 `xor` complement bco2 .&. bcu2 + ebo = bco2 `xor` complement bcu2 .&. bca2 + ebu = bcu2 `xor` complement bca2 .&. bce2 + abo2 = abo `xor` do1 + bca3 = rol abo2 28 + agu2 = agu `xor` du + bce3 = rol agu2 20 + aka2 = aka `xor` da + bci3 = rol aka2 3 + ame2 = ame `xor` de + bco3 = rol ame2 45 + asi2 = asi `xor` di + bcu3 = rol asi2 61 + ega = bca3 `xor` complement bce3 .&. bci3 + ege = bce3 `xor` complement bci3 .&. bco3 + egi = bci3 `xor` complement bco3 .&. bcu3 + ego = bco3 `xor` complement bcu3 .&. bca3 + egu = bcu3 `xor` complement bca3 .&. bce3 + + abe2 = abe `xor` de + bca4 = rol abe2 1 + agi2 = agi `xor` di + bce4 = rol agi2 6 + ako2 = ako `xor` do1 + bci4 = rol ako2 25 + amu2 = amu `xor` du + bco4 = rol amu2 8 + asa2 = asa `xor` da + bcu4 = rol asa2 18 + eka = bca4 `xor` complement bce4 .&. bci4 + eke = bce4 `xor` complement bci4 .&. bco4 + eki = bci4 `xor` complement bco4 .&. bcu4 + eko = bco4 `xor` complement bcu4 .&. bca4 + eku = bcu4 `xor` complement bca4 .&. bce4 + + abu2 = abu `xor` du + bca5 = rol abu2 27 + aga2 = aga `xor` da + bce5 = rol aga2 36 + ake2 = ake `xor` de + bci5 = rol ake2 10 + ami2 = ami `xor` di + bco5 = rol ami2 15 + aso2 = aso `xor` do1 + bcu5 = rol aso2 56 + + ema = bca5 `xor` complement bce5 .&. bci5 + eme = bce5 `xor` complement bci5 .&. bco5 + emi = bci5 `xor` complement bco5 .&. bcu5 + emo = bco5 `xor` complement bcu5 .&. bca5 + emu = bcu5 `xor` complement bca5 .&. bce5 + + abi2 = abi `xor` di + bca6 = rol abi2 62 + ago2 = ago `xor` do1 + bce6 = rol ago2 55 + aku2 = aku `xor` du + bci6 = rol aku2 39 + ama2 = ama `xor` da + bco6 = rol ama2 41 + ase2 = ase `xor` de + bcu6 = rol ase2 2 + esa = bca6 `xor` complement bce6 .&. bci6 + ese = bce6 `xor` complement bci6 .&. bco6 + esi = bci6 `xor` complement bco6 .&. bcu6 + eso = bco6 `xor` complement bcu6 .&. bca6 + esu = bcu6 `xor` complement bca6 .&. bce6 + + -- prepareTheta + bca7 = eba5 `xor` ega `xor` eka `xor` ema `xor` esa + bce7 = ebe `xor` ege `xor` eke `xor` eme `xor` ese + bci7 = ebi `xor` egi `xor` eki `xor` emi `xor` esi + bco7 = ebo `xor` ego `xor` eko `xor` emo `xor` eso + bcu7 = ebu `xor` egu `xor` eku `xor` emu `xor` esu + + -- thetaRhoPiChiIotaPrepareTheta(round+1, E, A) + da2 = bcu7 `xor` rol bce7 1 + de2 = bca7 `xor` rol bci7 1 + di2 = bce7 `xor` rol bco7 1 + do2 = bci7 `xor` rol bcu7 1 + du2 = bco7 `xor` rol bca7 1 + + eba6 = eba5 `xor` da2 + bca8 = eba6 + ege2 = ege `xor` de2 + bce8 = rol ege2 44 + eki2 = eki `xor` di2 + bci8 = rol eki2 43 + emo2 = emo `xor` do2 + bco8 = rol emo2 21 + esu2 = esu `xor` du2 + bcu8 = rol esu2 14 + aba3 = bca8 `xor` complement bce8 .&. bci8 + aba4 = aba3 `xor` (keccakFRoundConstants VU.! (round + 1)) + abe3 = bce8 `xor` complement bci8 .&. bco8 + abi3 = bci8 `xor` complement bco8 .&. bcu8 + abo3 = bco8 `xor` complement bcu8 .&. bca8 + abu3 = bcu8 `xor` complement bca8 .&. bce8 + + ebo2 = ebo `xor` do2 + bca9 = rol ebo2 28 + egu2 = egu `xor` du2 + bce9 = rol egu2 20 + eka2 = eka `xor` da2 + bci9 = rol eka2 3 + eme2 = eme `xor` de2 + bco9 = rol eme2 45 + esi2 = esi `xor` di2 + bcu9 = rol esi2 61 + aga3 = bca9 `xor` complement bce9 .&. bci9 + age3 = bce9 `xor` complement bci9 .&. bco9 + agi3 = bci9 `xor` complement bco9 .&. bcu9 + ago3 = bco9 `xor` complement bcu9 .&. bca9 + agu3 = bcu9 `xor` complement bca9 .&. bce9 + + ebe2 = ebe `xor` de2 + bcaA = rol ebe2 1 + egi2 = egi `xor` di2 + bceA = rol egi2 6 + eko2 = eko `xor` do2 + bciA = rol eko2 25 + emu2 = emu `xor` du2 + bcoA = rol emu2 8 + esa2 = esa `xor` da2 + bcuA = rol esa2 18 + aka3 = bcaA `xor` complement bceA .&. bciA + ake3 = bceA `xor` complement bciA .&. bcoA + aki3 = bciA `xor` complement bcoA .&. bcuA + ako3 = bcoA `xor` complement bcuA .&. bcaA + aku3 = bcuA `xor` complement bcaA .&. bceA + + ebu2 = ebu `xor` du2 + bcaB = rol ebu2 27 + ega2 = ega `xor` da2 + bceB = rol ega2 36 + eke2 = eke `xor` de2 + bciB = rol eke2 10 + emi2 = emi `xor` di2 + bcoB = rol emi2 15 + eso2 = eso `xor` do2 + bcuB = rol eso2 56 + ama3 = bcaB `xor` complement bceB .&. bciB + ame3 = bceB `xor` complement bciB .&. bcoB + ami3 = bciB `xor` complement bcoB .&. bcuB + amo3 = bcoB `xor` complement bcuB .&. bcaB + amu3 = bcuB `xor` complement bcaB .&. bceB + + ebi2 = ebi `xor` di2 + bcaC = rol ebi2 62 + ego2 = ego `xor` do2 + bceC = rol ego2 55 + eku2 = eku `xor` du2 + bciC = rol eku2 39 + ema2 = ema `xor` da2 + bcoC = rol ema2 41 + ese2 = ese `xor` de2 + bcuC = rol ese2 2 + asa3 = bcaC `xor` complement bceC .&. bciC + ase3 = bceC `xor` complement bciC .&. bcoC + asi3 = bciC `xor` complement bcoC .&. bcuC + aso3 = bcoC `xor` complement bcuC .&. bcaC + asu3 = bcuC `xor` complement bcaC .&. bceC + + result = VU.fromList [ aba4, abe3, abi3, abo3, abu3, aga3, age3, agi3, + ago3, agu3, aka3, ake3, aki3, ako3, aku3, ama3, + ame3, ami3, amo3, amu3, asa3, ase3, asi3, aso3, asu3] + + + +inputLoadVectors :: Int -> BS.ByteString -> Map.Map Int KeccakVector +inputLoadVectors rate input = do + let mlen = BS.length input + let inputOffsets = [0, rate .. mlen - rate] + Map.fromList $ fmap vectorAt inputOffsets + where + vectorAt offset = (offset, VU.fromList $ take keccakStateLength $ fmap valueAt [0 .. rate `div` 8 - 1] ++ repeat 0) + where + valueAt i = load64 input (offset + i * 8) + + + +-- start with the starting vector, xor with the next vector in the list and then permute. +-- the operations need to take place from left to right. +unifiedInputLoadVectors :: KeccakVector -> Int -> BS.ByteString -> KeccakVector +unifiedInputLoadVectors start rate input = go start inputs + where + inputs = Map.elems $ inputLoadVectors rate input + go start' [] = start' + go start' (input' : inputs') = go nextStart inputs' + where + nextStart = keccakF1600StatePermute $ VU.zipWith xor start' input' + + +keccakAbsorb :: Int -> BS.ByteString -> Word8 -> KeccakVector +keccakAbsorb rate input domainSep = s' + where + s = unifiedInputLoadVectors keccakEmpty rate input + s' = let loop ss i = ss VU.// [(i, (ss VU.! i) `xor` load64' t (8 * i))] + in foldl loop s [0 .. rate `div` 8 - 1] + + -- given a rate, an input, and a domain byte, produce the "t" + -- array used by the keccak absorb. + -- NOTE: input length is smaller than rate. not sure where this comes from. + t :: VU.Vector Word8 + t = VU.modify (\ v -> VUM.write v lastIndex (xor 128 (basic VU.! lastIndex))) basic + where + inputOffset = (inputLength `div` rate) * rate + input' = BS.drop inputOffset input + inputLength = BS.length input + inputLength' = BS.length input' + lastIndex = rate - 1 + basic = VU.concat [VU.fromList (BS.unpack input') + , VU.replicate 1 domainSep + , VU.replicate (rate - inputLength' - 1) 0 + ] + + +-- | Absorb step of SHAKE128 XOF. +shake128Absorb :: BS.ByteString -> KeccakVector +shake128Absorb seed = keccakAbsorb shake128Rate seed 0x1f + + +-- | Squeeze step of SHAKE128 XOF. Squeezes full blocks of +-- shake128Rate each. May be used incrementally. +shake128SqueezeBlocks :: KeccakVector -- ^ Initial state + -> Int -- ^ Number of blocks to process + -> (BS.ByteString, KeccakVector) -- ^ Resulting output and state +shake128SqueezeBlocks = flip keccakSqueezeblocks shake128Rate + + +-- | Squeeze step of Keccak. Squeezes full blocks of 'rate' bytes +-- each. May be used incrementally. +keccakSqueezeblocks :: KeccakVector -> Int -> Int -> (BS.ByteString, KeccakVector) +keccakSqueezeblocks state rate blocks + | blocks <= 0 = (BS.empty, state) + | otherwise = (BS.append output nextOutput, nextState) + where + state' = keccakF1600StatePermute state + toEncode = VU.take (rate `div` 8) state' -- just the first rate bytes (Word64 is eight of them!) + output = VU.foldl toLSB BS.empty toEncode + toLSB out inp = BS.append out (store64 inp) + (nextOutput, nextState) = keccakSqueezeblocks state' rate (blocks - 1) + + +-- | Completely absorb input data with the SHAKE256 XOF. +shake256 :: BS.ByteString -- ^ Data to be absorbed + -> Int -- ^ Desired output length + -> BS.ByteString +shake256 input outputLength = do + let state = keccakAbsorb shake256Rate input 0x1F + let nblocks = outputLength `div` shake256Rate + let (output, state') = keccakSqueezeblocks state shake256Rate nblocks + let extraBytes = outputLength `mod` shake256Rate + let (extraOutput, _) = keccakSqueezeblocks state' shake256Rate 1 + if extraBytes == 0 + then output + else BS.append output (BS.take extraBytes extraOutput) diff --git a/src/Crypto/NewHope/Internal/CCA_KEM.hs b/src/Crypto/NewHope/Internal/CCA_KEM.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Internal/CCA_KEM.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.CCA_KEM + Description : IND-CCA-secure operations for NewHope key exchange + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + IND-CPA-secure operations for the NewHope key exchange protocol. The + algorithm name is either NewHope512-CPAKEM or NewHope1024-CPAKEM, + depending on the value of N. + + This module contains the actual implementation. Exposed definitions + are in the 'Crypto.NewHope.CPA_KEM' module. + +-} + +module Crypto.NewHope.Internal.CCA_KEM where + + +import Control.DeepSeq +import qualified Data.ByteString as BS +import StringUtils + + +import qualified Crypto.NewHope.CPA_PKE as CPA_PKE +import Crypto.NewHope.FIPS202 +import Crypto.NewHope.Internals (N (N1024, N512), symBytes) +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.Poly (Poly) +import qualified Crypto.NewHope.Poly as Poly +import Crypto.NewHope.RNG +import Crypto.NewHope.Verify + + +-- * Counting bytes of our components. Note that all our sizes derive +-- at least in part from corresponding components in CPA_PKE. + +-- | A public key is this many bytes long. +publicKeyBytes :: Internals.N -> Int +publicKeyBytes = CPA_PKE.publicKeyBytes + +-- | A secret key is this many bytes long. +secretKeyBytes :: Internals.N -> Int +secretKeyBytes m = CPA_PKE.secretKeyBytes m + CPA_PKE.publicKeyBytes m + 2 * symBytes + +-- | A ciphertext is this many bytes long. +cipherTextBytes :: Internals.N -> Int +cipherTextBytes m = CPA_PKE.cipherTextBytes m + symBytes -- Second part is for Targhi-Unruh + + +-- * SharedSecret + +-- | The secret data posessed by both parties, resulting from the key +-- exchange protocol. +newtype SharedSecret = SharedSecret BS.ByteString deriving Eq + + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData SharedSecret + where + rnf (SharedSecret skData) = deepseq skData () + + +-- | Create a SharedSecret from a ByteString. +makeSharedSecret :: BS.ByteString -> SharedSecret +makeSharedSecret bs + | not lengthOK = error "Invalid length for SharedSecret" + | otherwise = SharedSecret bs + where + lengthOK = BS.length bs == Internals.sharedSecretBytes + + +-- | Necessary for `KAT` only. +getSSData :: SharedSecret -> BS.ByteString +getSSData (SharedSecret ssData) = ssData + + +-- * PublicKey + +-- | A public key; also the data sent from the first to the second party in the key exchange. +newtype PublicKey = PublicKey BS.ByteString deriving Eq + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData PublicKey + where + rnf _pk = () + +-- | Construct PublicKey from raw data +makePublicKey :: BS.ByteString -> PublicKey +makePublicKey bs + | not lengthOK = error "Invalid length for PublicKey" + | otherwise = PublicKey bs + where + len = BS.length bs + len512 = publicKeyBytes N512 + len1024 = publicKeyBytes N1024 + lengthOK = len == len512 || len == len1024 + + +-- | The data inside the PublicKey +getPKData :: PublicKey -> BS.ByteString +getPKData (PublicKey pkData) = pkData + + +----------------------- Extracting items from within our data + +-- | The N for this key +getPKn :: PublicKey -> Internals.N +getPKn (PublicKey pkData) + | len == len512 = N512 + | len == len1024 = N1024 + | otherwise = error "Invalid N for PublicKey" + where + len = BS.length pkData + len512 = publicKeyBytes N512 + len1024 = publicKeyBytes N1024 + + +-- | The encapsulated Poly +getPKPoly :: PublicKey -> Poly +getPKPoly pk@(PublicKey pkData) = Poly.fromByteString encoded +-- This is unused but important to retain as it is useful for documenting the structure of the data. + where + polyBytes = Poly.polyBytes $ getPKn pk + encoded = BS.take polyBytes pkData + + +-- | The data for the encapsulated Poly +getPKPolyData :: PublicKey -> BS.ByteString +getPKPolyData pk@(PublicKey pkData) = encoded +-- This is unused but important to retain as it is useful for documenting the structure of the data. + where + polyBytes = Poly.polyBytes $ getPKn pk + encoded = BS.take polyBytes pkData + + +-- | The data for the encapsulated Seed +getPKSeedData :: PublicKey -> BS.ByteString +getPKSeedData pk@(PublicKey pkData) = encoded +-- This is unused but important to retain as it is useful for documenting the structure of the data. + where + polyBytes = Poly.polyBytes $ getPKn pk + encoded = BS.drop polyBytes pkData + + +-- * SecretKey + +-- | A secret key; used to derive initiating party's copy of the +-- 'SharedSecret' in combination with a 'CipherText' from the +-- responding party. +newtype SecretKey = SecretKey BS.ByteString deriving Eq + +-- | We need this instance so that we can deepseq this data during performance tests. +instance NFData SecretKey + where + rnf _sk = () + +-- | Construct from raw data +makeSecretKey :: BS.ByteString -> SecretKey +makeSecretKey bs + | not lengthOK = error "Invalid length for SecretKey" + | otherwise = SecretKey bs + where + len = BS.length bs + len512 = secretKeyBytes N512 + len1024 = secretKeyBytes N1024 + lengthOK = len == len512 || len == len1024 + + +-- | The N for this key +getSKn :: SecretKey -> Internals.N +getSKn (SecretKey skData) + | len == len512 = N512 + | len == len1024 = N1024 + | otherwise = error "Invalid N for SecretKey" + where + len = BS.length skData + len512 = secretKeyBytes N512 + len1024 = secretKeyBytes N1024 + + +----------------------- Extracting items from within our data + +-- | The raw data comprising the SecretKey +getSKData :: SecretKey -> BS.ByteString +getSKData (SecretKey skData) = skData + + +-- | Raw data for the encapsulated CPA_PKE.SecretKey, which itself is an encoded Poly. +getSkPkeSecretKeyData :: SecretKey -> BS.ByteString +getSkPkeSecretKeyData sk@(SecretKey skData) = encoded + where + secretKeyBytes' = CPA_PKE.secretKeyBytes $ getSKn sk + encoded = BS.take secretKeyBytes' skData + + +-- | The encapsulated CPA_PKE.SecretKey +getSkSecretKey :: SecretKey -> CPA_PKE.SecretKey +getSkSecretKey sk = CPA_PKE.makeSecretKeyFromBytes $ getSkPkeSecretKeyData sk + + +-- | Raw data for the encapsulated CPA_PKE.PublicKey +getSkPkePublicKeyData :: SecretKey -> BS.ByteString +getSkPkePublicKeyData sk@(SecretKey skData) = encoded + where + n = getSKn sk + secretKeySize = CPA_PKE.secretKeyBytes n + publicKeySize = CPA_PKE.publicKeyBytes n + encoded = bsRange skData secretKeySize publicKeySize + + +-- | The encapsulated CPA_PKE.PublicKey +getSkPkePublicKey :: SecretKey -> CPA_PKE.PublicKey +getSkPkePublicKey = CPA_PKE.makePublicKeyFromBytes . getSkPkePublicKeyData + + +-- | The encapsulated hash +getSkPkHash :: SecretKey -> BS.ByteString +getSkPkHash sk@(SecretKey skData) = encoded + where + n = getSKn sk + secretKeySize = CPA_PKE.secretKeyBytes n + publicKeySize = CPA_PKE.publicKeyBytes n + offset = secretKeySize + publicKeySize + encoded = bsRange skData offset symBytes + +-- | I think this is called Z officially -- used as random data for failures. Does it have another use? +getSkZ :: SecretKey -> BS.ByteString +getSkZ sk@(SecretKey skData) = encoded + where + n = getSKn sk + secretKeySize = CPA_PKE.secretKeyBytes n + publicKeySize = CPA_PKE.publicKeyBytes n + offset = secretKeySize + publicKeySize + symBytes + encoded = bsRange skData offset symBytes + +-- * CipherText + +-- | Secret (encrypted) data sent from the responding party back to +-- the initiating party, used for initiating party to derive the +-- 'SharedSecret'. +newtype CipherText = CipherText BS.ByteString deriving Eq + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData CipherText + where + rnf _sk = () + + +-- | Construct from raw data. composed of CPA_PKE.cipherTextBytes +-- (polyBytes + polyCompressedBytes) and then symBytes (Targhi-Unruh +-- hash) +makeCipherText :: BS.ByteString -> CipherText +makeCipherText bs + | not lengthOK = error "Invalid length for CipherText" + | otherwise = CipherText bs + where + len = BS.length bs + len512 = cipherTextBytes N512 + len1024 = cipherTextBytes N1024 + lengthOK = len == len512 || len == len1024 + +-- | The N for this CipherText +getCTn :: CipherText -> Internals.N +getCTn (CipherText ctData) + | len == len512 = N512 + | len == len1024 = N1024 + | otherwise = error "Invalid N for CipherText" + where + len = BS.length ctData + len512 = cipherTextBytes N512 + len1024 = cipherTextBytes N1024 + + +-- | The raw data for this CipherText +getCTData :: CipherText -> BS.ByteString +getCTData (CipherText ctData) = ctData + + +-- | The encapsulated CPA_PKE.CipherText data +getCtCTData :: CipherText -> BS.ByteString +getCtCTData ct@(CipherText ctData) = encoded + where + n = getCTn ct + len = CPA_PKE.cipherTextBytes n + encoded = BS.take len ctData + + +-- | The encapsulated CPA_PKE.CipherText +getCtCT :: CipherText -> CPA_PKE.CipherText +getCtCT ct = CPA_PKE.makeCipherTextFromBytes $ getCtCTData ct + + +-- * Top-level operations + + +-- | The first step of the NewHope key exchange protocol. Called by +-- the initiating party, generates 'PublicKey' and 'SecretKey'. The +-- 'PublicKey' is sent to the receiving party for the next step in the +-- protocol. +keypair :: Context -> Internals.N -> (PublicKey, SecretKey, Context) +keypair ctx n = (makePublicKey pkData, makeSecretKey skData, ctx1) + where + (cpaPkePk, cpaPkeSk, ctx0) = CPA_PKE.keypair ctx n + + (extra, ctx1) = randomBytes ctx0 symBytes + + pkData = CPA_PKE.getPKData cpaPkePk -- all the data -- which is an encoded poly and a seed + skParts = [ CPA_PKE.getSKPolyData cpaPkeSk + , pkData + , shake256 pkData symBytes + , extra + ] + skData = foldr BS.append BS.empty skParts -- there must be a more idiomatic way to join a list of BSs + + +-- | For the provided 'PublicKey', generates a 'CipherText' and +-- 'SharedSecret'. Called by the receiving party, this produces that +-- party's version of the 'SharedSecret' and also the message to +-- transmit to the initiating party ('CipherText'). +encrypt :: Context -> PublicKey -> (CipherText, SharedSecret, Context) +encrypt ctx pk = (makeCipherText ctData, makeSharedSecret ss, ctx') + where + pkData = getPKData pk + + (buf, ctx') = randomBytes ctx symBytes + bufP1Shaken = shake256 buf symBytes -- Don't release system RNG output + + (coin0, coin12) = let bufPart2 = shake256 pkData symBytes -- Multitarget countermeasure for coins + contributory KEM + buf' = BS.append bufP1Shaken bufPart2 + kCoinsD = shake256 buf' (3 * symBytes) + in BS.splitAt symBytes kCoinsD -- coins are in kCoinsD+NEWHOPE_SYMBYTES + + (coin1, coin2) = BS.splitAt symBytes coin12 -- just the first symBytes part of buf + + ct = let seed = Internals.makeSeed coin1 + pt = CPA_PKE.makePlainText bufP1Shaken + pk' = CPA_PKE.makePublicKeyFromBytes pkData + in CPA_PKE.encrypt pt pk' seed + + ctData = let ctData' = CPA_PKE.getCTData ct + in BS.append ctData' coin2 -- copy Targhi-Unruh hash into ct + + coin1' = let n = getPKn pk + cipherTextBytes' = cipherTextBytes n + in shake256 (BS.take cipherTextBytes' ctData) symBytes -- overwrite coins in kCoinsD with h(c) + + kCoinsD' = BS.append coin0 coin1' + ss = shake256 kCoinsD' symBytes + + +-- | Called by the party initiating the protocol, this function +-- generates the 'SharedSecret' for the given 'CipherText' and +-- 'SecretKey'. The result is the initiating party's copy of the +-- 'SecretKey'. (In terms of encryption functions per se, it is also a +-- cleartext value.) +decrypt :: CipherText -> SecretKey -> (Bool, SharedSecret) +decrypt ct sk = (success, ss) +-- NOTE: by selective use of the ! annotation and the +-- `constantTimeChoose` function, this routine tries to keep +-- computation time invariant between successful and unsuccessful +-- decryptions -- be careful about changing it. Note that we also have +-- automated tests that attempt to verify this property. + where + ctData = getCTData ct + + buf = let buf' = let publicText = CPA_PKE.decrypt (getCtCT ct) (getSkSecretKey sk) + in CPA_PKE.getPTData publicText + in BS.append buf' $ getSkPkHash sk + + kCoinsD = shake256 buf (3 * symBytes) + + ctCmp = let coin2 = bsRange kCoinsD (2 * symBytes) symBytes + ctCmp' = let seed = bsRange kCoinsD symBytes symBytes + bufp1 = BS.take symBytes buf + in CPA_PKE.encrypt (CPA_PKE.makePlainText bufp1) (getSkPkePublicKey sk) (Internals.makeSeed seed) + in BS.append (CPA_PKE.getCTData ctCmp') coin2 + + success = verify ctData ctCmp + + ssData = let firstTwoCoins = let kCoinsD' = let coin1 = shake256 ctData symBytes + in bsReplace kCoinsD symBytes coin1 -- overwrite coins in kCoinsD with h(c) + replacementCoin = let coin0 = BS.take symBytes kCoinsD' + z = getSkZ sk + in constantTimeChoose success coin0 z -- overwrite pre-k with z on re-encryption failure (possibly replace with cmov) + kCoinsD'' = bsReplace kCoinsD' 0 replacementCoin + in BS.take (2 * symBytes) kCoinsD'' + in shake256 firstTwoCoins symBytes -- hash concatenation of pre-k and h(c) to k + !ss = makeSharedSecret ssData + diff --git a/src/Crypto/NewHope/Internal/CPA_KEM.hs b/src/Crypto/NewHope/Internal/CPA_KEM.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Internal/CPA_KEM.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.Internal.CPA_KEM + Description : IND-CPA-secure operations for the NewHope key exchange protocol + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + IND-CPA-secure operations for the NewHope key exchange protocol. The + algorithm name is either NewHope512-CPAKEM or NewHope1024-CPAKEM, + depending on the value of N. + + This module contains the actual implementation. Exposed definitions + are in the 'Crypto.NewHope.CPA_KEM' module. + +-} + +module Crypto.NewHope.Internal.CPA_KEM where + + +import Control.DeepSeq +import qualified Data.ByteString as BS + + +import qualified Crypto.NewHope.CPA_PKE as CPA_PKE +import Crypto.NewHope.FIPS202 +import Crypto.NewHope.Internals (N (N1024, N512)) +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.RNG + + +-- * Counting bytes + +-- | Size of a PublicKey +publicKeyBytes :: Internals.N -> Int +publicKeyBytes = CPA_PKE.publicKeyBytes + +-- | Size of a SecretKey +secretKeyBytes :: Internals.N -> Int +secretKeyBytes = CPA_PKE.secretKeyBytes + +-- | Size of a CipherText +cipherTextBytes :: Internals.N -> Int +cipherTextBytes = CPA_PKE.cipherTextBytes + + +-- * PublicKey + +-- | A public key; also the data sent from the first to the second +-- party in the key exchange. +newtype PublicKey = PublicKey BS.ByteString + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData PublicKey + where + rnf (PublicKey pkData) = seq pkData () + + +-- | Construct a PublicKey from a ByteString of exactly the right +-- size. The result will be a key of N512 or N1024 accordingly. +makePublicKey :: BS.ByteString -> PublicKey +makePublicKey pkData + | not lengthOK = error "Invalid length for PublicKey" + | otherwise = PublicKey pkData + where + len = BS.length pkData + len512 = publicKeyBytes N512 + len1024 = publicKeyBytes N1024 + lengthOK = len == len512 || len == len1024 + + +-- | The raw data inside the PublicKey +getPKData :: PublicKey -> BS.ByteString +getPKData (PublicKey pkData) = pkData + + +-- * SecretKey + +-- | A secret key; used to derive initiating party's copy of the +-- 'SharedSecret' in combination with a 'CipherText' from the +-- responding party. +newtype SecretKey = SecretKey BS.ByteString + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData SecretKey + where + rnf (SecretKey skData) = seq skData () + + +-- | Construct a SecretKey from a ByteString of exactly the right +-- size. The result will be a key of N512 or N1024 accordingly. +makeSecretKey :: BS.ByteString -> SecretKey +makeSecretKey skData + | not lengthOK = error "Invalid length for SecretKey" + | otherwise = SecretKey skData + where + len = BS.length skData + len512 = secretKeyBytes N512 + len1024 = secretKeyBytes N1024 + lengthOK = len == len512 || len == len1024 + +-- | The raw data inside the SecretKey +getSKData :: SecretKey -> BS.ByteString +getSKData (SecretKey skData) = skData + + +-- * CipherText + +-- | Secret data sent from the responding party back to the initiating +-- party, used for initiating party to derive the 'SharedSecret'. +newtype CipherText = CipherText BS.ByteString + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData CipherText + where + rnf (CipherText ctData) = seq ctData () + + +-- | Construct a CipherText from a ByteString of exactly the right +-- size. The result will be of N512 or N1024, accordingly. +makeCipherText :: BS.ByteString -> CipherText +makeCipherText ctData + | not lengthOK = error "Invalid length for CipherText" + | otherwise = CipherText ctData + where + len = BS.length ctData + len512 = cipherTextBytes N512 + len1024 = cipherTextBytes N1024 + lengthOK = len == len512 || len == len1024 + + +-- | The raw data inside the CipherText +getCTData :: CipherText -> BS.ByteString +getCTData (CipherText ctData) = ctData + + +-- * SharedSecret + +-- | The secret data posessed by both parties, resulting from the key +-- exchange protocol. +newtype SharedSecret = SharedSecret BS.ByteString deriving Eq + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData SharedSecret + where + rnf (SharedSecret ssData) = seq ssData () + + +-- | Construct a SharedSecret from a ByteString of length +-- 'sharedSecretBytes'. +makeSharedSecret :: BS.ByteString -> SharedSecret +makeSharedSecret pkData + | not lengthOK = error "Invalid length for SharedSecret." + | otherwise = SharedSecret pkData + where + goodLength = Internals.sharedSecretBytes + actualLength = BS.length pkData + lengthOK = actualLength == goodLength + +-- | The raw data inside the SharedSecret +getSSData :: SharedSecret -> BS.ByteString +getSSData (SharedSecret ssData) = ssData + + +-- * Top-level operations + + +-- | The first step of the NewHope key exchange protocol. Called by +-- the initiating party, generates 'PublicKey' and 'SecretKey'. The +-- 'PublicKey' is sent to the receiving party for the next step in the +-- protocol. +keypair :: Context -> Internals.N -> (PublicKey, SecretKey, Context) +keypair ctx n = (pk', sk', ctx') + where + -- Note that this encapsulates keys returned by CPA_PKE. + (pk, sk, ctx') = CPA_PKE.keypair ctx n + pk' = makePublicKey $ CPA_PKE.getPKData pk + sk' = makeSecretKey $ CPA_PKE.getSKPolyData sk + + +-- | For the provided 'PublicKey', generates a 'CipherText' and +-- 'SharedSecret'. Called by the receiving party, this produces that +-- party's version of the 'SharedSecret' and also the message to +-- transmit to the initiating party ('CipherText'). +encrypt :: Context -> PublicKey -> (CipherText, SharedSecret, Context) +encrypt ctx pk = (ct, ss, ctx') + where + symBytes = fromIntegral Internals.symBytes + (buf, ctx') = randomBytes ctx symBytes + + (buf0, buf1) = let buf_2sym = shake256 buf (2 * symBytes) + in BS.splitAt symBytes buf_2sym -- we use them separately; coins are buf1 and buf0 used as cleartext + + ct = let ct' = let pk' = CPA_PKE.makePublicKeyFromBytes $ getPKData pk + in CPA_PKE.encrypt (CPA_PKE.makePlainText buf0) pk' (Internals.makeSeed buf1) + in makeCipherText $ CPA_PKE.getCTData ct' + + ss = let ss' = shake256 buf0 symBytes -- hash pre-k to ss + in makeSharedSecret ss' + + +-- | Called by the party initiating the protocol, this function +-- generates the 'SharedSecret' for the given 'CipherText' and +-- 'SecretKey'. The result is the initiating party's copy of the +-- 'SecretKey'. (In terms of encryption functions per se, it is also a +-- cleartext value.) +decrypt :: CipherText -> SecretKey -> SharedSecret +decrypt ct sk = SharedSecret ss + where + ss = let ss' = let ct' = CPA_PKE.makeCipherTextFromBytes $ getCTData ct + sk' = CPA_PKE.makeSecretKeyFromBytes $ getSKData sk + in CPA_PKE.decrypt ct' sk' + symBytes = fromIntegral Internals.symBytes + in shake256 (CPA_PKE.getPTData ss') symBytes -- hash pre-k to ss diff --git a/src/Crypto/NewHope/Internal/RNG.hs b/src/Crypto/NewHope/Internal/RNG.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Internal/RNG.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Internal.RNG + Description : Implements the CTR-DRBG standard on top of AES256. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + CTR-DRBG == Counter mode Deterministic Random Byte Generator. + In addition, there are a few useful extras. + + Please see https://nvlpubs.nist.gov/nistpubs/SpecialPublications/NIST.SP.800-90Ar1.pdf + for details on the standard. + + This module contains the actual implementation. Exposed definitions + are in the 'Crypto.NewHope.RNG' module. + +-} + +module Crypto.NewHope.Internal.RNG where + + +import Codec.Crypto.AES +import Control.DeepSeq +import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Semigroup ((<>)) +import Data.Word + + +newtype RandomSeed = RandomSeed BS.ByteString + +randomSeedBytes :: Int +randomSeedBytes = 48 + +getRandomSeedData :: RandomSeed -> BS.ByteString +getRandomSeedData (RandomSeed rsData) = rsData + + +-- | Strings or ByteStrings may be used for source data. +class RandomSeedable a + where + -- | Uses external entropy (precisely 48 bytes) to create a 'RandomSeed', used for initializing the pseudorandom number generator + makeRandomSeed :: a -> RandomSeed + +instance RandomSeedable String + where + makeRandomSeed s | not lengthOK = error $ "Invalid length for RandomSeed. Have " ++ show len ++ " and require " ++ show randomSeedBytes ++ " bytes." + | otherwise = RandomSeed $ BSC.pack s + where + len = Prelude.length s + lengthOK = len == randomSeedBytes + +instance RandomSeedable BS.ByteString + where + makeRandomSeed bs | not lengthOK = error $ "Invalid length for RandomSeed. Have " ++ show len ++ " and require " ++ show randomSeedBytes ++ " bytes." + | otherwise = RandomSeed bs + where + len = BS.length bs + lengthOK = len == randomSeedBytes + + +-- * Key + +newtype Key = Key { getKey :: BS.ByteString } deriving (Eq) + +keyBytes :: Int +keyBytes = 32 -- 32 * 8 == 64 * 4 == 128 * 2 == 256 bits + +createKey :: BS.ByteString -> Key +createKey value + | BS.length value /= keyBytes = error "Incorrect key length" + | otherwise = Key { getKey = value } + + +-- * V + +newtype V = V { getV :: BS.ByteString } deriving (Eq) + +-- | The size of a V in bytes +vBytes :: Int +vBytes = 16 -- 16 * 8 == 32 * 4 == 64 * 2 == 128 bits + +-- | Construct a V +createV :: BS.ByteString -> V +createV value + | BS.length value /= vBytes = error $ "Incorrect V length: " ++ show (BS.length value) + | otherwise = V { getV = value } + + +-- | Increment the V +incrementV :: V -> V +incrementV (V v) = let v' = reverse $ BS.unpack v + v'' = go v' + v''' = BS.pack $ reverse v'' + + go [] = [] + go (0xff : is) = 0 : go is + go (i : is) = (i + 1) : is + in V v''' + + +----------------------- + +-- | State for pseudorandom number generation +data Context = Context { ctxKey :: Key + , ctxV :: V + , ctxReseedCounter :: Int + } deriving (Eq) + +-- | We need this instance so that we can deepseq this data while doing performance tests. +instance NFData Context + where + rnf Context { ctxKey = key, ctxV = v } = seq key seq v () + + +-- | Update the context with new data +update :: Context -> Maybe BS.ByteString -> Context +update ctx providedData = let + _ = ctxReseedCounter ctx + Key key = ctxKey ctx + v = ctxV ctx + + ecbModeDoesNotUseIV = BS.pack $ replicate 16 0 + + (_, chunks) = foldr go (v, []) [0 .. (2 :: Int)] + where + go _ (_v, _chunks) = (v', encrypted : _chunks) + where + v' = incrementV _v + encrypted = crypt' ECB key ecbModeDoesNotUseIV Encrypt (getV v') + + chunks' = reverse chunks + unified = mconcat chunks' + unified' = case providedData of + Nothing -> unified + Just providedData' -> BS.pack $ BS.zipWith xor unified providedData' + + (nextKeyData, nextVData) = BSC.splitAt 32 unified' + nextKey = createKey nextKeyData + nextV = createV nextVData + ctx' = ctx { ctxKey = nextKey, ctxV = nextV } + in ctx' + + + +-- * Higher-level functions using Context data + +-- | Creates a 'Context' as state for the pseudorandom number generator, required for key exchange operations +randomBytesInit :: RandomSeed -- ^ External entropy to seed the generator + -> Maybe RandomSeed -- ^ Optional additional entropy to include + -> Integer -- ^ Security strength: unused by this implementation + -> Context -- ^ The resulting PRNG state +randomBytesInit seed personalization _securityStrength = update ctx (Just seedMaterial) + where + RandomSeed entropyInput = seed + seedMaterial = BS.pack $ case personalization of + Nothing -> BS.unpack entropyInput + Just (RandomSeed persData) -> zipWith xor (BS.unpack entropyInput) (BS.unpack persData) + -- initial version with dummy data; it gets immediatlely replaced with the update. + ctx = Context { ctxKey = createKey $ BS.pack $ replicate keyBytes 0 + , ctxV = createV $ BS.pack $ replicate vBytes 0 + , ctxReseedCounter = 1 + } + + +-- | Generate pseudorandom bytes from the Context. +randomBytes :: Context -> Int -> (BS.ByteString, Context) +randomBytes ctx count = (result, ctx'') + where + result = BS.take count $ BSL.toStrict $ Builder.toLazyByteString results -- last block could be partial + blocks = ceiling $ (fromIntegral count :: Double) / 16 + counter = ctxReseedCounter ctx + 1 + key = getKey $ ctxKey ctx + ecbModeDoesNotUseIV = BS.pack $ replicate 16 0 + ctx'' = update ctx' { ctxReseedCounter = counter } Nothing + (results, ctx') = foldr go (Builder.byteString BS.empty, ctx) [1 .. blocks :: Int] + where + go _ (_results, _ctx) = (_results <> Builder.byteString block, _ctx') + where + v = incrementV $ ctxV _ctx + block = crypt' ECB key ecbModeDoesNotUseIV Encrypt (getV v) + _ctx' = _ctx { ctxV = v } + + + +-- * Useful extras + +-- | Computes a random Word64 along with the next context to use. If +-- you want a full-range Word64 value, this is what you want. If you +-- want a pretty evenly-distributed random number in a given range, +-- see randomInteger below. +nextWord64 :: Context -> (Word64, Context) +nextWord64 ctx = (value, ctx') + where + (fourBytes, ctx') = randomBytes ctx 4 + fourBytes' = BS.unpack fourBytes + value = shiftL (fromIntegral (fourBytes' !! 0)) 24 + .|. shiftL (fromIntegral (fourBytes' !! 1)) 16 + .|. shiftL (fromIntegral (fourBytes' !! 2)) 8 + .|. fromIntegral (fourBytes' !! 3) + + +-- | Computes a random Integer in the given range, along with the next +-- context to use. This function body is derived from and very +-- similar to randomIvalInteger as defined in System.Random (© 2001 +-- The University of Glasgow). Since this is a public domain algorithm +-- and a purely functional expression thereof, I don't think that the +-- below causes the licensing terms of the foregoing to need +-- incorporation here, but I welcome correction. +randomInteger :: Context -> (Integer, Integer) -> (Integer, Context) +randomInteger ctx (minValue, maxValue) + | minValue > maxValue = randomInteger ctx (maxValue, minValue) + | otherwise = (fromInteger (minValue + v `mod` k), ctx') + where + (v, ctx') = accumulate 1 0 ctx + (genlo, genhi) = (minBound, maxBound) :: (Word64, Word64) + b = fromIntegral genhi - fromIntegral genlo + 1 + q = 1000 + k = maxValue - minValue + 1 + magtgt = k * q + + accumulate mag vv ctx0 + | mag >= magtgt = (vv, ctx0) + | otherwise = v' `seq` accumulate (mag * b) v' ctx0' + where + (x, ctx0') = nextWord64 ctx0 + v' = vv * b + (fromIntegral x - fromIntegral genlo) diff --git a/src/Crypto/NewHope/Internal/SeedExpander.hs b/src/Crypto/NewHope/Internal/SeedExpander.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Internal/SeedExpander.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_HADDOCK prune #-} +{-| + Module : Crypto.NewHope.Internal.SeedExpander + Description : Seed expander for NewHope. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + The "seed expander" is a facility specified by NIST for generating + pseudorandom data given a seed. It is not used in the actual NewHope + key exchange and is provided here for completeness/isomorphism with + the NewHope C reference library. + + This module contains the actual implementation. Exposed definitions + are in the 'Crypto.NewHope.SeedExpander' module. + + + * Sample usage + + @ + let maxLen' = case maxLen 256 of Right value -> value + Left x -> error (show x) + + let diversifier = case createDiversifier (BSC.pack "12345678") of Right value -> value + Left x -> error (show x) + + let seed = (Internals.makeSeed "32 bytes of seed data go here...") + + let ctx = case seedexpanderInit seed diversifier maxLen' of Right value -> value + Left x -> error (show x) + + let (ctx', buf) = case seedexpander ctx 16 of Right value -> value + Left x r -> error (show x) + @ + +-} + +module Crypto.NewHope.Internal.SeedExpander where + +import Codec.Crypto.AES +import Control.Monad.Except +import Data.Bits +import Data.Semigroup ((<>)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as BSL +import Data.Word + +import qualified Crypto.NewHope.Internals as Internals +import qualified Crypto.NewHope.Internal.RNG as RNG + + +-- | Error conditions detected in creation and use of 'Context' data +data RNGError = BadDiversifierLen | BadMaxLen | BadReqLen deriving (Show) + + +-- | Maintains state for a series of calls to generate pseudorandom data via 'seedexpander'. +data Context = Context { ctxBuffer :: BS.ByteString + , ctxBufferPos :: Word64 + , ctxLengthRemaining :: Word64 + , ctxKey :: RNG.Key + , ctxCounter :: RNG.V + } deriving (Eq) + + +-- | Contains extra seed material for initializing SeedExpander +newtype Diversifier = Diversifier BS.ByteString deriving Show + +-- | Specifies eight bytes of data for use as part of the seed material to be expanded. +createDiversifier :: (MonadError RNGError m) => BS.ByteString -> m Diversifier +createDiversifier bs + | BS.length bs /= 8 = throwError BadDiversifierLen + | otherwise = return $ Diversifier bs + + +-- | Contains the maximum number of bytes that a 'Context' will generate. +newtype MaxLen = MaxLen Word64 + +-- | Specifies the maximum number of bytes that a 'Context' will generate. +maxLen :: (MonadError RNGError m) => Word64 -> m MaxLen +maxLen n + | n < 0 || n > 0x100000000 = throwError BadMaxLen + | otherwise = return $ MaxLen n + + +-- | Create a 'Context' for generation of data. +seedexpanderInit :: (MonadError RNGError m) => Internals.Seed -> Diversifier -> MaxLen -> m Context +seedexpanderInit (Internals.Seed seed) (Diversifier diversifier) (MaxLen maxLength) = return ctx + where + ctx = Context { ctxBuffer = BS.pack $ replicate 16 0 -- irrelevant; will be discarded on first update + , ctxBufferPos = 16 -- at the end, so the first call will fill it + , ctxLengthRemaining = maxLength + , ctxKey = RNG.createKey seed + , ctxCounter = createCounter + } + + -- Structure of counter: + -- 00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 + -- DIVERSIFIER-----------| maxlen----| 00 00 00 00 + -- MSB LSB + + createCounter :: RNG.V + createCounter = RNG.createV value + where + maxlenFourBytes = fromIntegral $ maxLength .&. 0xFFffFFff + zeroCounter = 0 + value = BS.pack (BS.unpack diversifier + ++ BSL.unpack (Builder.toLazyByteString (Builder.word32BE maxlenFourBytes)) + ++ BSL.unpack (Builder.toLazyByteString (Builder.word32BE zeroCounter))) + + +-- | Generate pseudorandom data from the given 'Context'. The returned +-- pair contains the requested data and the next 'Context' to use. +seedexpander :: (MonadError RNGError m) => Context -> Word64 -> m (BS.ByteString, Context) +seedexpander ctx xlen + | xlen >= ctxLengthRemaining ctx = throwError BadReqLen -- i'd think it would be > and not >= but reference source' uses >= + | xlen < 0 = return (BS.pack [], ctx) + | xlen <= (16 - bufferPos) = return (existingBufferResult, ctx'0) + | otherwise = do -- more than a single buffer's worth, or more than we have left in buffer + (result', ctx') <- seedexpander ctx'1 xlen' + return (restOfExistingBuffer <> result', ctx') + where + bufferPos = ctxBufferPos ctx + bytesUsedOfBuffer = min (16 - bufferPos) (min xlen 16) -- how much from current buffer we'll use + + restOfExistingBuffer = BS.drop (fromIntegral bufferPos) (ctxBuffer ctx) -- all of the unused bytes in the current buffer + existingBufferResult = BS.take (fromIntegral bytesUsedOfBuffer) restOfExistingBuffer -- the actual bytes we'll use from the buffer. + -- (only calculated if we don't need more bytes) + + -- For when we are returning bytes from our existing buffer. + lengthRemaining = ctxLengthRemaining ctx - fromIntegral bytesUsedOfBuffer -- how many bytes will be left in the Context? + ctx'0 = ctx { ctxBufferPos = bufferPos + xlen, + ctxLengthRemaining = lengthRemaining + } + + -- When the existing buffer does not satisfy our appetite, prepare the next buffer and context. + ctx'1 = ctx { ctxCounter = RNG.incrementV $ ctxCounter ctx + , ctxBufferPos = 0 + , ctxBuffer = nextBuffer + , ctxLengthRemaining = lengthRemaining + } + where + nextBuffer = crypt' ECB keyValue ecbModeDoesNotUseIV Encrypt payloadValue + where + RNG.Key keyValue = ctxKey ctx + RNG.V payloadValue = ctxCounter ctx + ecbModeDoesNotUseIV = BS.pack $ replicate 16 0 -- we'd use ⊥ but the AES library evaluates it, even for ECB + + xlen' = xlen - bytesUsedOfBuffer diff --git a/src/Crypto/NewHope/Internals.hs b/src/Crypto/NewHope/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Internals.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.Internals + Description : Internal constants and functions + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Internal constants and functions + +-} + +module Crypto.NewHope.Internals where + +import Control.DeepSeq +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + + +-- | There are two legal parameter sets for NewHope: either 512 or 1024. +data N = N512 -- ^ Represents the N=512 parameter set + | N1024 -- ^ Represents the N=1024 parameter set + deriving (Eq) + +-- | The numerical value of the parameter set in question +value :: N -> Int +value N512 = 512 +value N1024 = 1024 + + +q :: Int +q = 12289 + + +-- | The size of shared key, seeds/coins, and hashes +symBytes :: Int +symBytes = 32 + +-- | The size of a Seed +seedBytes :: Int +seedBytes = symBytes + +-- | The size of SharedSecrets +sharedSecretBytes :: Int +sharedSecretBytes = symBytes + + +-- | Data used throughout the NewHope implementation. Externally, used +-- to initialize the SeedExpander pseudorandom number generator. +newtype Seed = Seed BS.ByteString deriving Eq + +-- | We need this instance so that we can deepseq this data for performance tests. +instance NFData Seed + where + rnf (Seed seedData) = seq seedData () + + +-- | Extract data from the Seed +getSeedData :: Seed -> BS.ByteString +getSeedData (Seed seedData) = seedData + + +-- | Seeds may be constructed using Strings or ByteStrings as source data. +class Seedable a + where + -- | Uses external entropy (precisely 32 bytes) to create a 'Seed'. + makeSeed :: a -> Seed + +instance Seedable BS.ByteString + where + makeSeed bs | not lengthOK = error $ "Invalid length for Seed. Have " ++ show len ++ " and require " ++ show symBytes ++ " bytes." + | otherwise = Seed bs + where + len = BS.length bs + lengthOK = len == symBytes + +instance Seedable String + where + makeSeed s | not lengthOK = error $ "Invalid length for Seed. Have " ++ show len ++ " and require " ++ show symBytes ++ " bytes." + | otherwise = Seed $ BSC.pack s + where + len = length s + lengthOK = len == symBytes diff --git a/src/Crypto/NewHope/NTT.hs b/src/Crypto/NewHope/NTT.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/NTT.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.NTT + Description : Number-theoretic transforms for NewHope. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Number-theoretic transforms for NewHope. + + See: https://en.wikipedia.org/wiki/Discrete_Fourier_transform_(general)#Number-theoretic_transform + +-} + +module Crypto.NewHope.NTT where + + +import Data.Bits +import qualified Data.Vector.Unboxed as VU +import Data.Word + +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.Reduce (montgomeryReduce) + + +type NTTVector = VU.Vector Word16 + +-- | Bit-reverse a vector. See https://en.wikipedia.org/wiki/Bit-reversal_permutation +bitrev :: NTTVector -> NTTVector +bitrev p = VU.imap go p + where + table = case len of + 512 -> bitrevTable512 + 1024 -> bitrevTable1024 + _ -> error "unexpected vector length" + len = VU.length p + go i _ = p VU.! fromIntegral (table VU.! i) + + +-- | Performs pointwise (coefficient-wise) multiplication of two +-- polynomials. The factors parameter contains coefficients assumed +-- to be in Montgomery representation. +mulCoefficients :: NTTVector -- ^ first polynomial, in standard representation + -> NTTVector -- ^ second polynomial ("factors"), in Montgomery representation + -> NTTVector +mulCoefficients = VU.zipWith go + where + go a b = montgomeryReduce (fromIntegral a * fromIntegral b) + + +getPreReduce :: Integral a => a -> a -> a -> Word32 +getPreReduce a b w = w' * (a' + (3 :: Word32) * q - b') + where + a' = fromIntegral a :: Word32 + b' = fromIntegral b :: Word32 + q = fromIntegral Internals.q :: Word32 + w' = fromIntegral w :: Word32 + + +-- | Computes number-theoretic transform (NTT) of a polynomial. +-- Inputs are bit-reversed, output is in standard order. +ntt :: NTTVector -- ^ Input polynomial, in bit-reversed order + -> NTTVector -- ^ Powers of root of unity omega, in Montgomery domain + -> NTTVector -- ^ Result polynomial, in normal order +ntt vec ω = foldl go vec [0, 2, 4, 6, 8] + where + vectorLength = VU.length vec + + modVec :: NTTVector -> Int -> Word16 -> Int -> Word16 -> NTTVector + modVec διάνυσμα index value index2 value2 = διάνυσμα VU.// [(index, value), (index2, value2)] + + go :: NTTVector -> Int -> NTTVector + go διάνυσμα i = if i >= 8 && vectorLength == 512 + then vec' else vec'' + where + vec' = foldl (process distanceEven True) διάνυσμα [0..distanceEven-1] + vec'' = foldl (process distanceOdd False) vec' [0..distanceOdd-1] + distanceEven = shift 1 i + distanceOdd = shift distanceEven 1 + + process :: Int -> Bool -> NTTVector -> Int -> NTTVector + process distance isEven vic start = foldl jLoop vic joinedParams + where + increment = 2 * distance + second = start + increment + limit = vectorLength - 2 + items = [start, second..limit] + joinedParams = zip items [0..] + + jLoop :: NTTVector -> (Int, Int) -> NTTVector + jLoop vac (j, jTwiddle) = modVec vac j value0 j' value1 + where + j' = j + distance + w = ω VU.! jTwiddle + temp = vac VU.! j + ajdist = vac VU.! j' + value0 = if isEven + then temp + ajdist + else (temp + ajdist) `mod` fromIntegral Internals.q + preReduce = getPreReduce temp ajdist w + value1 = montgomeryReduce preReduce + + +-- | Contains bit-reversed 9-bit indices to be used to re-order +-- polynomials before number theoratic transform +bitrevTable :: Int -> NTTVector +bitrevTable bits = case bits of + 512 -> bitrevTable512 + 1024 -> bitrevTable1024 + _ -> error "Unsupported" + +-- | The 512-item version of the vector +bitrevTable512 :: NTTVector +bitrevTable512 = VU.fromList [ 0,256,128,384,64,320,192,448,32,288,160,416,96,352,224,480,16,272,144,400,80,336,208, + 464,48,304,176,432,112,368,240,496,8,264,136,392,72,328,200,456,40,296,168,424,104, + 360,232,488,24,280,152,408,88,344,216,472,56,312,184,440,120,376,248,504,4,260,132, + 388,68,324,196,452,36,292,164,420,100,356,228,484,20,276,148,404,84,340,212,468,52, + 308,180,436,116,372,244,500,12,268,140,396,76,332,204,460,44,300,172,428,108,364,236, + 492,28,284,156,412,92,348,220,476,60,316,188,444,124,380,252,508,2,258,130,386,66, + 322,194,450,34,290,162,418,98,354,226,482,18,274,146,402,82,338,210,466,50,306,178, + 434,114,370,242,498,10,266,138,394,74,330,202,458,42,298,170,426,106,362,234,490,26, + 282,154,410,90,346,218,474,58,314,186,442,122,378,250,506,6,262,134,390,70,326,198, + 454,38,294,166,422,102,358,230,486,22,278,150,406,86,342,214,470,54,310,182,438,118, + 374,246,502,14,270,142,398,78,334,206,462,46,302,174,430,110,366,238,494,30,286,158, + 414,94,350,222,478,62,318,190,446,126,382,254,510,1,257,129,385,65,321,193,449,33, + 289,161,417,97,353,225,481,17,273,145,401,81,337,209,465,49,305,177,433,113,369,241, + 497,9,265,137,393,73,329,201,457,41,297,169,425,105,361,233,489,25,281,153,409,89, + 345,217,473,57,313,185,441,121,377,249,505,5,261,133,389,69,325,197,453,37,293,165, + 421,101,357,229,485,21,277,149,405,85,341,213,469,53,309,181,437,117,373,245,501,13, + 269,141,397,77,333,205,461,45,301,173,429,109,365,237,493,29,285,157,413,93,349,221, + 477,61,317,189,445,125,381,253,509,3,259,131,387,67,323,195,451,35,291,163,419,99, + 355,227,483,19,275,147,403,83,339,211,467,51,307,179,435,115,371,243,499,11,267,139, + 395,75,331,203,459,43,299,171,427,107,363,235,491,27,283,155,411,91,347,219,475,59, + 315,187,443,123,379,251,507,7,263,135,391,71,327,199,455,39,295,167,423,103,359,231, + 487,23,279,151,407,87,343,215,471,55,311,183,439,119,375,247,503,15,271,143,399,79, + 335,207,463,47,303,175,431,111,367,239,495,31,287,159,415,95,351,223,479,63,319,191, + 447,127,383,255,511] + + +-- | The 1024-item version of the vector +bitrevTable1024 :: NTTVector +bitrevTable1024 = VU.fromList [ 0,512,256,768,128,640,384,896,64,576,320,832,192,704,448,960,32,544,288,800,160,672, + 416,928,96,608,352,864,224,736,480,992,16,528,272,784,144,656,400,912,80,592,336, + 848,208,720,464,976,48,560,304,816,176,688,432,944,112,624,368,880,240,752,496,1008, + 8,520,264,776,136,648,392,904,72,584,328,840,200,712,456,968,40,552,296,808,168,680, + 424,936,104,616,360,872,232,744,488,1000,24,536,280,792,152,664,408,920,88,600,344, + 856,216,728,472,984,56,568,312,824,184,696,440,952,120,632,376,888,248,760,504,1016, + 4,516,260,772,132,644,388,900,68,580,324,836,196,708,452,964,36,548,292,804,164,676, + 420,932,100,612,356,868,228,740,484,996,20,532,276,788,148,660,404,916,84,596,340, + 852,212,724,468,980,52,564,308,820,180,692,436,948,116,628,372,884,244,756,500,1012, + 12,524,268,780,140,652,396,908,76,588,332,844,204,716,460,972,44,556,300,812,172, + 684,428,940,108,620,364,876,236,748,492,1004,28,540,284,796,156,668,412,924,92,604, + 348,860,220,732,476,988,60,572,316,828,188,700,444,956,124,636,380,892,252,764,508, + 1020,2,514,258,770,130,642,386,898,66,578,322,834,194,706,450,962,34,546,290,802, + 162,674,418,930,98,610,354,866,226,738,482,994,18,530,274,786,146,658,402,914,82, + 594,338,850,210,722,466,978,50,562,306,818,178,690,434,946,114,626,370,882,242,754, + 498,1010,10,522,266,778,138,650,394,906,74,586,330,842,202,714,458,970,42,554,298, + 810,170,682,426,938,106,618,362,874,234,746,490,1002,26,538,282,794,154,666,410,922, + 90,602,346,858,218,730,474,986,58,570,314,826,186,698,442,954,122,634,378,890,250, + 762,506,1018,6,518,262,774,134,646,390,902,70,582,326,838,198,710,454,966,38,550, + 294,806,166,678,422,934,102,614,358,870,230,742,486,998,22,534,278,790,150,662,406, + 918,86,598,342,854,214,726,470,982,54,566,310,822,182,694,438,950,118,630,374,886, + 246,758,502,1014,14,526,270,782,142,654,398,910,78,590,334,846,206,718,462,974,46, + 558,302,814,174,686,430,942,110,622,366,878,238,750,494,1006,30,542,286,798,158,670, + 414,926,94,606,350,862,222,734,478,990,62,574,318,830,190,702,446,958,126,638,382, + 894,254,766,510,1022,1,513,257,769,129,641,385,897,65,577,321,833,193,705,449,961, + 33,545,289,801,161,673,417,929,97,609,353,865,225,737,481,993,17,529,273,785,145, + 657,401,913,81,593,337,849,209,721,465,977,49,561,305,817,177,689,433,945,113,625, + 369,881,241,753,497,1009,9,521,265,777,137,649,393,905,73,585,329,841,201,713,457, + 969,41,553,297,809,169,681,425,937,105,617,361,873,233,745,489,1001,25,537,281,793, + 153,665,409,921,89,601,345,857,217,729,473,985,57,569,313,825,185,697,441,953,121, + 633,377,889,249,761,505,1017,5,517,261,773,133,645,389,901,69,581,325,837,197,709, + 453,965,37,549,293,805,165,677,421,933,101,613,357,869,229,741,485,997,21,533,277, + 789,149,661,405,917,85,597,341,853,213,725,469,981,53,565,309,821,181,693,437,949, + 117,629,373,885,245,757,501,1013,13,525,269,781,141,653,397,909,77,589,333,845,205, + 717,461,973,45,557,301,813,173,685,429,941,109,621,365,877,237,749,493,1005,29,541, + 285,797,157,669,413,925,93,605,349,861,221,733,477,989,61,573,317,829,189,701,445, + 957,125,637,381,893,253,765,509,1021,3,515,259,771,131,643,387,899,67,579,323,835, + 195,707,451,963,35,547,291,803,163,675,419,931,99,611,355,867,227,739,483,995,19, + 531,275,787,147,659,403,915,83,595,339,851,211,723,467,979,51,563,307,819,179,691, + 435,947,115,627,371,883,243,755,499,1011,11,523,267,779,139,651,395,907,75,587,331, + 843,203,715,459,971,43,555,299,811,171,683,427,939,107,619,363,875,235,747,491,1003, + 27,539,283,795,155,667,411,923,91,603,347,859,219,731,475,987,59,571,315,827,187, + 699,443,955,123,635,379,891,251,763,507,1019,7,519,263,775,135,647,391,903,71,583, + 327,839,199,711,455,967,39,551,295,807,167,679,423,935,103,615,359,871,231,743,487, + 999,23,535,279,791,151,663,407,919,87,599,343,855,215,727,471,983,55,567,311,823, + 183,695,439,951,119,631,375,887,247,759,503,1015,15,527,271,783,143,655,399,911,79, + 591,335,847,207,719,463,975,47,559,303,815,175,687,431,943,111,623,367,879,239,751, + 495,1007,31,543,287,799,159,671,415,927,95,607,351,863,223,735,479,991,63,575,319, + 831,191,703,447,959,127,639,383,895,255,767,511,1023] diff --git a/src/Crypto/NewHope/Poly.hs b/src/Crypto/NewHope/Poly.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Poly.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Poly + Description : Polynomials and related operations. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Polynomials and related operations. + +-} + +module Crypto.NewHope.Poly where + +import Control.DeepSeq +import Control.Monad.State (join) +import Data.Bits +import qualified Data.ByteString as BS +import Data.Int +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Data.Word +import GHC.Generics (Generic) +import Prelude hiding (length) + +import Crypto.NewHope.FIPS202 +import Crypto.NewHope.Internals (N (N1024, N512)) +import qualified Crypto.NewHope.Internals as Internals +import qualified Crypto.NewHope.NTT as NTT +import Crypto.NewHope.Precomp +import Crypto.NewHope.Reduce (montgomeryReduce) +import MiscUtils + + +-- | Our Poly vectors are always of length N. +newtype Poly = Poly (VU.Vector Word16) deriving (Eq, Show, Generic, NFData) + + +-- | Bytes taken by regular encoded polynomials. +polyBytes :: N -> Int +polyBytes v = (14 * Internals.value v) `div` 8 + +-- | Bytes taken by a Poly-derived msg. +polyMsgBytes :: Int +polyMsgBytes = Internals.symBytes + +-- | Bytes taken by a compressed Poly. +polyCompressedBytes :: N -> Int +polyCompressedBytes v = (3 * Internals.value v) `div` 8 + + +-- | The length of this Poly +length :: Poly -> Int +length (Poly v) = VU.length v + + +-- | The parameter set to which this Poly belongs +getN :: Poly -> N +getN p = case length p of + 512 -> N512 + 1024 -> N1024 + _ -> error "Unexpected Poly length" + + +-- | Fully reduces an integer modulo q in constant time. Returns +-- integer in {0,...,q-1} congruent to x modulo q. +coeffFreeze :: Word16 -> Word16 +coeffFreeze x = r' + where + q = fromIntegral Internals.q + r = x `mod` q + m = r - q + c = fromIntegral (fromIntegral m :: Int16) :: Int16 + c' = shiftR c 15 + c'word = fromIntegral c' :: Word16 + r' = m `xor` ((r `xor` m) .&. c'word) + + +-- | computes |(x mod q) - Q/2| +flipabs :: Word16 -> Word16 +flipabs x = fromIntegral $ xor m (r' + m) + where + q :: Int + q = fromIntegral Internals.q + r = fromIntegral $ coeffFreeze x + r' = r - (q `div` 2) + m = shiftR r' 15 + + +-- | Deserialize +fromByteString :: BS.ByteString -> Poly +fromByteString a + | not bytesOK = error $ "Invalid number (" ++ show bytes ++ ") of serialized bytes for Poly." + | otherwise = Poly result + where + bytes = BS.length a + bytes512 = polyBytes N512 + bytes1024 = polyBytes N1024 + bytesOK = (bytes == bytes512) || (bytes == bytes1024) + + result = VU.fromList $ fmap fromIntegral joined + joined = join folded + folded = Prelude.foldr go [] as + as = Prelude.take (bytes `div` 4) $ VU.fromList <$> chunk 7 (fromIntegral <$> BS.unpack a :: [Word16]) + + go b c = [i0, i1, i2, i3] : c + where + b0 = b VU.! 0 + b1 = b VU.! 1 + b2 = b VU.! 2 + b3 = b VU.! 3 + b4 = b VU.! 4 + b5 = b VU.! 5 + b6 = b VU.! 6 + + i0 = b0 .|. shiftL (b1 .&. 0x3f) 8 + i1 = shiftR b1 6 .|. shiftL b2 2 .|. shiftL (b3 .&. 0x0f) 10 + i2 = shiftR b3 4 .|. shiftL b4 4 .|. shiftL (b5 .&. 0x03) 12 + i3 = shiftR b5 2 .|. shiftL b6 6 + + +-- | Serialize +toByteString :: Poly -> BS.ByteString +toByteString (Poly v) = results + where + results = foldr go BS.empty inputVectors + inputVectors = chunk 4 v + + go a = BS.append newItems + where + newItems = BS.pack $ fmap fromIntegral [i0, i1, i2, i3, i4, i5, i6] + + t0 = coeffFreeze $ a VU.! 0 + t1 = coeffFreeze $ a VU.! 1 + t2 = coeffFreeze $ a VU.! 2 + t3 = coeffFreeze $ a VU.! 3 + + i0 = t0 .&. 0xff + i1 = shiftR t0 8 .|. shiftL t1 6 + i2 = shiftR t1 2 + i3 = shiftR t1 10 .|. shiftL t2 4 + i4 = shiftR t2 4 + i5 = shiftR t2 12 .|. shiftL t3 2 + i6 = shiftR t3 6 + + +-- | Compression + serialization +compress :: Poly -> BS.ByteString +compress (Poly pData) = result + where + ts = VU.map t pData + input = chunk 8 ts + + t :: Word16 -> Word32 + t n = fromIntegral $ div (shiftL n' 3 + (q `div` 2)) q .&. 0x07 + where + n' = fromIntegral $ coeffFreeze n + q = Internals.q + + result = BS.pack $ join $ fmap process input + where + process :: VU.Vector Word32 -> [Word8] + process i = [ fromIntegral $ i0 .|. shiftL i1 3 .|. shiftL i2 6 + , fromIntegral $ shiftR i2 2 .|. shiftL i3 1 .|. shiftL i4 4 .|. shiftL i5 7 + , fromIntegral $ shiftR i5 1 .|. shiftL i6 2 .|. shiftL i7 5 + ] + where + i0 = i VU.! 0 + i1 = i VU.! 1 + i2 = i VU.! 2 + i3 = i VU.! 3 + i4 = i VU.! 4 + i5 = i VU.! 5 + i6 = i VU.! 6 + i7 = i VU.! 7 + + +-- | De-serialization and subsequent decompression of a polynomial; +-- approximate inverse of compress +decompress :: BS.ByteString -> Poly +decompress input = Poly $ VU.fromList result + where + inputChunks = chunk 3 $ VU.fromList (fromIntegral <$> BS.unpack input) + process :: VU.Vector Word16 -> [Word16] + process a = [ a0 .&. 7 + , shiftR a0 3 .&. 7 + , shiftR a0 6 .|. (shiftL a1 2 .&. 4) + , shiftR a1 1 .&. 7 + , shiftR a1 4 .&. 7 + , shiftR a1 7 .|. (shiftL a2 1 .&. 6) + , shiftR a2 2 .&. 7 + , shiftR a2 5 + ] + where + a0 = a VU.! 0 + a1 = a VU.! 1 + a2 = a VU.! 2 + + finalize :: Word16 -> Word16 + finalize x = fromIntegral $ shiftR ((fromIntegral x :: Word32) * fromIntegral Internals.q + 4) 3 + result = fmap finalize $ join $ fmap process inputChunks + + +-- | Restore/convert from (32-byte) message +fromMsg :: N -> BS.ByteString -> Poly +fromMsg n msg = Poly vector' + where + msg' = VU.fromList $ BS.unpack msg + empty = VU.replicate 256 0 + vector' + | n == N512 = vector VU.++ vector + | n == N1024 = vector VU.++ vector VU.++ vector VU.++ vector + | otherwise = error "Invalid N" + vector = foldr go empty [0..31] + where + go i b = foldr go' b [0..7] + where + go' j = VU.modify (\v -> VUM.write v base value) + where + base = 8 * i + j + mask = - ((fromIntegral (msg' VU.! i) `shiftR` j) .&. 1) + value = mask .&. (fromIntegral Internals.q `div` 2) + + +-- | Convert polynomial to (32-byte) message +toMsg :: Poly -> BS.ByteString +toMsg p@(Poly x) = BS.pack result + where + result = foldr (.|.) 0 <$> chunked + chunked = chunk 8 ts + + ts = t <$> [0..255] + where + n = getN p + + offsets + | n == N512 = [0, 256] + | n == N1024 = [0, 256, 512, 768] + | otherwise = error "Invalid vector size" + + tExtra :: Num a => a + tExtra = fromIntegral $ if n == N1024 + then Internals.q + else Internals.q `div` 2 + + t :: Int -> Word8 + t i = fromIntegral shifted + where + offsets' = (+i) <$> offsets + values = (x VU.!) <$> offsets' + values' = flipabs <$> values + summed = sum values' - tExtra + shifted = shiftL (shiftR summed 15) (i .&. 7) + + +-- | Sample a polynomial deterministically from a seed, with output +-- polynomial looking uniformly random +uniform :: N -> Internals.Seed -> Poly +uniform n seed = Poly vector + where + Internals.Seed seed' = seed + size = Internals.value n + vector = let empty = VU.replicate size (0 :: Word16) + go :: Int -> VU.Vector Word16 -> VU.Vector Word16 + go i victor = victor' + where + (_, victor') = let (buf, _) = let extseed = BS.snoc seed' (fromIntegral i) + staite = shake128Absorb extseed + in shake128SqueezeBlocks staite 1 + bufBS = VU.fromList $ BS.unpack buf + in go' bufBS 0 0 victor + + go' :: VU.Vector Word8 -> Int -> Int -> VU.Vector Word16 -> (Int, VU.Vector Word16) + go' buf ctr j vactor = if j' < shake128Rate && ctr' < 64 + then go' buf ctr' j' vactor' + else (ctr', vactor') + where + val = let b0 = fromIntegral $ buf VU.! j + b1 = fromIntegral $ buf VU.! (j + 1) + in b0 .|. shiftL b1 8 :: Word16 + moveCounter = val < 5 * fromIntegral Internals.q + vactor' = if moveCounter + then VU.modify (\v -> VUM.write v (i * 64 + ctr) val) vactor + else vactor + ctr' = if moveCounter + then ctr + 1 + else ctr + j' = j + 2 + in foldr go empty [0..size `div` 64 - 1] + + +-- | The Hamming weight of a byte (the number of 1s) +hw :: Word8 -> Word8 +hw a = sum [shiftR a i .&. 1 | i <- [0..7]] + + +-- | Sample a polynomial deterministically from a seed and a nonce, +-- with output polynomial close to centered binomial distribution with +-- parameter k=8 +sample :: N -> Internals.Seed -> Word8 -> Poly +sample n seed nonce = Poly $ foldr go empty [0..size `div` 64 - 1] + where + size = Internals.value n + empty = VU.replicate size 0 + seed' = let Internals.Seed seedData = seed + in BS.snoc seedData nonce + + go i vector = foldr go' vector [0..63] + where + extseed = BS.snoc seed' $ fromIntegral i + buf = shake256 extseed 128 + + go' j victor = victor' + where + a = fromIntegral.hw $ BS.index buf (2 * j) + b = fromIntegral.hw $ BS.index buf (2 * j + 1) + + index = 64 * i + j + value = a + fromIntegral Internals.q - b + victor' = VU.modify (\v -> VUM.write v index value) victor + + +-- | Multiply two polynomials pointwise (i.e., coefficient-wise). +mulPointwise :: Poly -> Poly -> Poly +mulPointwise (Poly a) (Poly b) = Poly $ VU.zipWith go a b +-- NOTE: we don't check that these are the same length, which is fine given existing code. +-- NOTE: this is not commutative. + where + go c d = value + where + t = montgomeryReduce (3186 * fromIntegral d) -- t is now in Montgomery domain + value = montgomeryReduce (fromIntegral c * fromIntegral t) -- back in normal domain + + +-- | Add two polynomials +add :: Poly -> Poly -> Poly +add (Poly a) (Poly b) = Poly $ VU.zipWith go a b +-- NOTE: we don't check that these are the same length, which is fine given existing code. +-- NOTE: this is not commutative. should it be? + where + go c d = (c + d) `mod` fromIntegral Internals.q + + +-- | Subtract two polynomials +sub :: Poly -> Poly -> Poly +sub (Poly a) (Poly b) = Poly $ VU.zipWith go a b + where + q = fromIntegral Internals.q + go c d = (c + (3 * q) - d) `mod` q + + +-- | Forward NTT transform of a polynomial +-- input is assumed to have coefficients in bitreversed order output +-- has coefficients in normal order +ntt :: Poly -- ^ input polynomial, in bitreversed order + -> Poly -- ^ transformed polynomial, in normal order +ntt p@(Poly r) = Poly result + where + n = getN p + multiplied = NTT.mulCoefficients r $ ψBitrevMontgomery n + result = NTT.ntt multiplied $ ωBitrevMontgomery n + + +-- | Inverse NTT transform of a polynomial +-- +-- Output has coefficients in normal order +invntt :: Poly -- ^ input, with coefficients in normal order + -> Poly -- ^ output, with coefficients in normal order +invntt p@(Poly r) = Poly result + where + n = getN p + r' = NTT.bitrev r + r'' = NTT.ntt r' $ ωInvBitrevMontgomery n + result = NTT.mulCoefficients r'' $ ψInvMontgomery n diff --git a/src/Crypto/NewHope/Precomp.hs b/src/Crypto/NewHope/Precomp.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Precomp.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Precomp + Description : Precompiled vectors for use by various polynomial-manipulating functions. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Precomp where + +import qualified Data.Vector.Unboxed as VU +import Data.Word + +import Crypto.NewHope.Internals (N (N1024, N512)) + +-- | powers of nth root of unity in Montgomery +-- domain with R=2^18 in bit-reversed order +ωBitrevMontgomery :: N -> VU.Vector Word16 +ωBitrevMontgomery n = case n of + N512 -> ωBitrevMontgomery512 + N1024 -> ωBitrevMontgomery1024 + + +-- | ω table for N512 +ωBitrevMontgomery512 :: VU.Vector Word16 +ωBitrevMontgomery512 = VU.fromList [ 4075,5315,7965,7373,522,10120,9027,5079,2344,1278,1973,5574,1018,6364,11248,8775, + 7500,7822,5537,4749,8500,12142,5456,7840,5445,3860,4536,11239,6171,8471,2683,11099, + 10561,400,6137,7341,5415,8646,6136,5862,5529,5206,56,9090,8724,11635,1702,10302, + 5339,6843,6093,3710,316,382,11821,8301,10930,5435,11035,973,8291,10256,8410,1922, + 12097,10968,10240,4912,4698,5057,7509,8844,8807,11502,5468,1010,9162,8120,2920,5241, + 6055,8953,677,5874,2766,10966,12237,9115,12138,10162,3957,2839,6383,2505,11858,1579, + 9026,3600,6077,4624,11868,4080,6068,3602,605,9987,504,8076,4782,6403,3029,6695, + 11184,142,5681,8812,2844,3438,8077,975,58,12048,1003,8757,885,6281,1956,5009, + 12225,3656,11606,9830,1566,5782,2503,2948,7032,3834,5919,4433,3054,6803,9166,1747, + 10211,11177,4322,1958,922,11848,4079,11231,4046,11580,1319,9139,6224,835,8049,8719, + 7105,1200,6122,9734,3956,1360,6119,5297,4298,3329,168,2692,1594,10327,5106,6328, + 3728,8240,5990,11130,948,1146,10885,325,8212,4016,8527,2919,295,6190,652,5766, + 11713,8326,6142,2447,1805,2882,10238,1954,1843,9928,4115,3030,2908,12071,8760,3434, + 5876,2281,2031,5333,8298,8320,12133,2767,11836,5908,11871,8517,6860,7515,10996,4737, + 2500,10800,5942,1583,11026,12240,5915,10806,1815,5383,1512,11939,2057,6920,9087,7796, + 8974,426,4754,1858,8532,10314,11942,2925,174,11566,3009,1693,2655,6554,5868,2738] + +-- | ω table for N1024 +ωBitrevMontgomery1024 :: VU.Vector Word16 +ωBitrevMontgomery1024 = VU.fromList [ 4075,6974,7373,7965,3262,5079,522,2169,6364,1018,1041,8775,2344,11011,5574,1973, + 4536,1050,6844,3860,3818,6118,2683,1190,4789,7822,7540,6752,5456,4449,3789,12142, + 11973,382,3988,468,6843,5339,6196,3710,11316,1254,5435,10930,3998,10256,10367,3879, + 11889,1728,6137,4948,5862,6136,3643,6874,8724,654,10302,1702,7083,6760,56,3199, + 9987,605,11785,8076,5594,9260,6403,4782,6212,4624,9026,8689,4080,11868,6221,3602, + 975,8077,8851,9445,5681,3477,1105,142,241,12231,1003,3532,5009,1956,6008,11404, + 7377,2049,10968,12097,7591,5057,3445,4780,2920,7048,3127,8120,11279,6821,11502,8807, + 12138,2127,2839,3957,431,1579,6383,9784,5874,677,3336,6234,2766,1323,9115,12237, + 2031,6956,6413,2281,3969,3991,12133,9522,4737,10996,4774,5429,11871,3772,453,5908, + 2882,1805,2051,1954,11713,3963,2447,6142,8174,3030,1843,2361,12071,2908,3529,3434, + 3202,7796,2057,5369,11939,1512,6906,10474,11026,49,10806,5915,1489,9789,5942,10706, + 10431,7535,426,8974,3757,10314,9364,347,5868,9551,9634,6554,10596,9280,11566,174, + 2948,2503,6507,10723,11606,2459,64,3656,8455,5257,5919,7856,1747,9166,5486,9235, + 6065,835,3570,4240,11580,4046,10970,9139,1058,8210,11848,922,7967,1958,10211,1112, + 3728,4049,11130,5990,1404,325,948,11143,6190,295,11637,5766,8212,8273,2919,8527, + 6119,6992,8333,1360,2555,6167,1200,7105,7991,3329,9597,12121,5106,5961,10695,10327, + 3051,9923,4896,9326,81,3091,1000,7969,4611,726,1853,12149,4255,11112,2768,10654, + 1062,2294,3553,4805,2747,4846,8577,9154,1170,2319,790,11334,9275,9088,1326,5086, + 9094,6429,11077,10643,3504,3542,8668,9744,1479,1,8246,7143,11567,10984,4134,5736, + 4978,10938,5777,8961,4591,5728,6461,5023,9650,7468,949,9664,2975,11726,2744,9283, + 10092,5067,12171,2476,3748,11336,6522,827,9452,5374,12159,7935,3296,3949,9893,4452, + 10908,2525,3584,8112,8011,10616,4989,6958,11809,9447,12280,1022,11950,9821,11745,5791, + 5092,2089,9005,2881,3289,2013,9048,729,7901,1260,5755,4632,11955,2426,10593,1428, + 4890,5911,3932,9558,8830,3637,5542,145,5179,8595,3707,10530,355,3382,4231,9741, + 1207,9041,7012,1168,10146,11224,4645,11885,10911,10377,435,7952,4096,493,9908,6845, + 6039,2422,2187,9723,8643,9852,9302,6022,7278,1002,4284,5088,1607,7313,875,8509, + 9430,1045,2481,5012,7428,354,6591,9377,11847,2401,1067,7188,11516,390,8511,8456, + 7270,545,8585,9611,12047,1537,4143,4714,4885,1017,5084,1632,3066,27,1440,8526, + 9273,12046,11618,9289,3400,9890,3136,7098,8758,11813,7384,3985,11869,6730,10745,10111, + 2249,4048,2884,11136,2126,1630,9103,5407,2686,9042,2969,8311,9424,9919,8779,5332, + 10626,1777,4654,10863,7351,3636,9585,5291,8374,2166,4919,12176,9140,12129,7852,12286, + 4895,10805,2780,5195,2305,7247,9644,4053,10600,3364,3271,4057,4414,9442,7917,2174] + + +-- | inverses of powers of nth root of unity in Montgomery domain with +-- R=2^18 in bit-reversed order +ωInvBitrevMontgomery :: N -> VU.Vector Word16 +ωInvBitrevMontgomery n = case n of + N512 -> ωInvBitrevMontgomery512 + N1024 -> ωInvBitrevMontgomery1024 + + +-- | inverse ω table for N512 +ωInvBitrevMontgomery512 :: VU.Vector Word16 +ωInvBitrevMontgomery512 = VU.fromList [ 4075,6974,4916,4324,7210,3262,2169,11767,3514,1041,5925,11271,6715,10316,11011,9945, + 1190,9606,3818,6118,1050,7753,8429,6844,4449,6833,147,3789,7540,6752,4467,4789, + 10367,3879,2033,3998,11316,1254,6854,1359,3988,468,11907,11973,8579,6196,5446,6950, + 1987,10587,654,3565,3199,12233,7083,6760,6427,6153,3643,6874,4948,6152,11889,1728, + 7280,10333,6008,11404,3532,11286,241,12231,11314,4212,8851,9445,3477,6608,12147,1105, + 5594,9260,5886,7507,4213,11785,2302,11684,8687,6221,8209,421,7665,6212,8689,3263, + 10710,431,9784,5906,9450,8332,2127,151,3174,52,1323,9523,6415,11612,3336,6234, + 7048,9369,4169,3127,11279,6821,787,3482,3445,4780,7232,7591,7377,2049,1321,192, + 9551,6421,5735,9634,10596,9280,723,12115,9364,347,1975,3757,10431,7535,11863,3315, + 4493,3202,5369,10232,350,10777,6906,10474,1483,6374,49,1263,10706,6347,1489,9789, + 7552,1293,4774,5429,3772,418,6381,453,9522,156,3969,3991,6956,10258,10008,6413, + 8855,3529,218,9381,9259,8174,2361,10446,10335,2051,9407,10484,9842,6147,3963,576, + 6523,11637,6099,11994,9370,3762,8273,4077,11964,1404,11143,11341,1159,6299,4049,8561, + 5961,7183,1962,10695,9597,12121,8960,7991,6992,6170,10929,8333,2555,6167,11089,5184, + 3570,4240,11454,6065,3150,10970,709,8243,1058,8210,441,11367,10331,7967,1112,2078, + 10542,3123,5486,9235,7856,6370,8455,5257,9341,9786,6507,10723,2459,683,8633,64] + +-- | inverse ω table for N1024 +ωInvBitrevMontgomery1024 :: VU.Vector Word16 +ωInvBitrevMontgomery1024 = VU.fromList [ 4075,5315,4324,4916,10120,11767,7210,9027,10316,6715,1278,9945,3514,11248,11271,5925, + 147,8500,7840,6833,5537,4749,4467,7500,11099,9606,6171,8471,8429,5445,11239,7753, + 9090,12233,5529,5206,10587,1987,11635,3565,5415,8646,6153,6427,7341,6152,10561,400, + 8410,1922,2033,8291,1359,6854,11035,973,8579,6093,6950,5446,11821,8301,11907,316, + 52,3174,10966,9523,6055,8953,11612,6415,2505,5906,10710,11858,8332,9450,10162,151, + 3482,787,5468,1010,4169,9162,5241,9369,7509,8844,7232,4698,192,1321,10240,4912, + 885,6281,10333,7280,8757,11286,58,12048,12147,11184,8812,6608,2844,3438,4212,11314, + 8687,6068,421,8209,3600,3263,7665,6077,7507,5886,3029,6695,4213,504,11684,2302, + 1962,1594,6328,7183,168,2692,8960,4298,5184,11089,6122,9734,10929,3956,5297,6170, + 3762,9370,4016,4077,6523,652,11994,6099,1146,11341,11964,10885,6299,1159,8240,8561, + 11177,2078,10331,4322,11367,441,4079,11231,3150,1319,8243,709,8049,8719,11454,6224, + 3054,6803,3123,10542,4433,6370,7032,3834,8633,12225,9830,683,1566,5782,9786,9341, + 12115,723,3009,1693,5735,2655,2738,6421,11942,2925,1975,8532,3315,11863,4754,1858, + 1583,6347,2500,10800,6374,1483,12240,1263,1815,5383,10777,350,6920,10232,4493,9087, + 8855,8760,9381,218,9928,10446,9259,4115,6147,9842,8326,576,10335,10238,10484,9407, + 6381,11836,8517,418,6860,7515,1293,7552,2767,156,8298,8320,10008,5876,5333,10258, + 10115,4372,2847,7875,8232,9018,8925,1689,8236,2645,5042,9984,7094,9509,1484,7394, + 3,4437,160,3149,113,7370,10123,3915,6998,2704,8653,4938,1426,7635,10512,1663, + 6957,3510,2370,2865,3978,9320,3247,9603,6882,3186,10659,10163,1153,9405,8241,10040, + 2178,1544,5559,420,8304,4905,476,3531,5191,9153,2399,8889,3000,671,243,3016, + 3763,10849,12262,9223,10657,7205,11272,7404,7575,8146,10752,242,2678,3704,11744,5019, + 3833,3778,11899,773,5101,11222,9888,442,2912,5698,11935,4861,7277,9808,11244,2859, + 3780,11414,4976,10682,7201,8005,11287,5011,6267,2987,2437,3646,2566,10102,9867,6250, + 5444,2381,11796,8193,4337,11854,1912,1378,404,7644,1065,2143,11121,5277,3248,11082, + 2548,8058,8907,11934,1759,8582,3694,7110,12144,6747,8652,3459,2731,8357,6378,7399, + 10861,1696,9863,334,7657,6534,11029,4388,11560,3241,10276,9000,9408,3284,10200,7197, + 6498,544,2468,339,11267,9,2842,480,5331,7300,1673,4278,4177,8705,9764,1381, + 7837,2396,8340,8993,4354,130,6915,2837,11462,5767,953,8541,9813,118,7222,2197, + 3006,9545,563,9314,2625,11340,4821,2639,7266,5828,6561,7698,3328,6512,1351,7311, + 6553,8155,1305,722,5146,4043,12288,10810,2545,3621,8747,8785,1646,1212,5860,3195, + 7203,10963,3201,3014,955,11499,9970,11119,3135,3712,7443,9542,7484,8736,9995,11227, + 1635,9521,1177,8034,140,10436,11563,7678,4320,11289,9198,12208,2963,7393,2366,9238] + + +-- | powers of nth root of -1 in Montgomery +-- domain with R=2^18 in bit-reversed order +ψBitrevMontgomery :: N -> VU.Vector Word16 +ψBitrevMontgomery n = case n of + N512 -> ψBitrevMontgomery512 + N1024 -> ψBitrevMontgomery1024 + + +-- | ψ table for N512 +ψBitrevMontgomery512 :: VU.Vector Word16 +ψBitrevMontgomery512 = VU.fromList [ 4075,5315,7965,7373,522,10120,9027,5079,2344,1278,1973,5574,1018,6364,11248,8775, + 7500,7822,5537,4749,8500,12142,5456,7840,5445,3860,4536,11239,6171,8471,2683,11099, + 10561,400,6137,7341,5415,8646,6136,5862,5529,5206,56,9090,8724,11635,1702,10302, + 5339,6843,6093,3710,316,382,11821,8301,10930,5435,11035,973,8291,10256,8410,1922, + 12097,10968,10240,4912,4698,5057,7509,8844,8807,11502,5468,1010,9162,8120,2920,5241, + 6055,8953,677,5874,2766,10966,12237,9115,12138,10162,3957,2839,6383,2505,11858,1579, + 9026,3600,6077,4624,11868,4080,6068,3602,605,9987,504,8076,4782,6403,3029,6695, + 11184,142,5681,8812,2844,3438,8077,975,58,12048,1003,8757,885,6281,1956,5009, + 12225,3656,11606,9830,1566,5782,2503,2948,7032,3834,5919,4433,3054,6803,9166,1747, + 10211,11177,4322,1958,922,11848,4079,11231,4046,11580,1319,9139,6224,835,8049,8719, + 7105,1200,6122,9734,3956,1360,6119,5297,4298,3329,168,2692,1594,10327,5106,6328, + 3728,8240,5990,11130,948,1146,10885,325,8212,4016,8527,2919,295,6190,652,5766, + 11713,8326,6142,2447,1805,2882,10238,1954,1843,9928,4115,3030,2908,12071,8760,3434, + 5876,2281,2031,5333,8298,8320,12133,2767,11836,5908,11871,8517,6860,7515,10996,4737, + 2500,10800,5942,1583,11026,12240,5915,10806,1815,5383,1512,11939,2057,6920,9087,7796, + 8974,426,4754,1858,8532,10314,11942,2925,174,11566,3009,1693,2655,6554,5868,2738, + 11796,8193,9908,5444,10911,1912,7952,435,404,7644,11224,10146,7012,11121,11082,9041, + 9723,2187,9867,6250,3646,9852,6267,2987,8509,875,4976,10682,8005,5088,7278,11287, + 9223,27,3763,10849,11272,7404,5084,10657,8146,4714,12047,10752,2678,3704,545,7270, + 1067,5101,442,2401,390,11516,3778,8456,1045,9430,9808,5012,9377,6591,11935,4861, + 7852,3,3149,12129,12176,4919,10123,3915,3636,7351,2704,5291,1663,1777,1426,7635, + 1484,7394,2780,7094,8236,2645,7247,2305,2847,7875,7917,10115,10600,8925,4057,3271, + 9273,243,9289,11618,3136,5191,8889,9890,11869,5559,10111,10745,11813,8758,4905,3985, + 9603,9042,3978,9320,3510,5332,9424,2370,9405,11136,2249,8241,10659,10163,9103,6882, + 10810,1,5146,4043,8155,5736,11567,1305,1212,10643,9094,5860,8747,8785,8668,2545, + 4591,6561,5023,6461,10938,4978,6512,8961,949,2625,2639,7468,11726,2975,9545,9283, + 3091,81,11289,7969,9238,9923,2963,7393,12149,1853,11563,7678,8034,11112,1635,9521, + 3201,3014,1326,7203,1170,9970,11334,790,3135,3712,4846,2747,3553,7484,11227,2294, + 11267,9,9447,11809,11950,2468,5791,11745,10908,9764,8112,3584,4989,5331,4278,10616, + 4452,9893,8340,8993,130,7935,9452,6915,8541,11336,11462,5767,7222,2197,12171,9813, + 3241,729,3289,10276,9408,3284,2089,5092,11029,4388,5755,7657,10861,1696,2426,11955, + 4231,2548,11934,3382,10530,3707,3694,7110,3637,8830,6747,145,7399,5911,2731,8357] + +-- | ψ table for N1024 +ψBitrevMontgomery1024 :: VU.Vector Word16 +ψBitrevMontgomery1024 = VU.fromList [ 4075,6974,7373,7965,3262,5079,522,2169,6364,1018,1041,8775,2344,11011,5574,1973, + 4536,1050,6844,3860,3818,6118,2683,1190,4789,7822,7540,6752,5456,4449,3789,12142, + 11973,382,3988,468,6843,5339,6196,3710,11316,1254,5435,10930,3998,10256,10367,3879, + 11889,1728,6137,4948,5862,6136,3643,6874,8724,654,10302,1702,7083,6760,56,3199, + 9987,605,11785,8076,5594,9260,6403,4782,6212,4624,9026,8689,4080,11868,6221,3602, + 975,8077,8851,9445,5681,3477,1105,142,241,12231,1003,3532,5009,1956,6008,11404, + 7377,2049,10968,12097,7591,5057,3445,4780,2920,7048,3127,8120,11279,6821,11502,8807, + 12138,2127,2839,3957,431,1579,6383,9784,5874,677,3336,6234,2766,1323,9115,12237, + 2031,6956,6413,2281,3969,3991,12133,9522,4737,10996,4774,5429,11871,3772,453,5908, + 2882,1805,2051,1954,11713,3963,2447,6142,8174,3030,1843,2361,12071,2908,3529,3434, + 3202,7796,2057,5369,11939,1512,6906,10474,11026,49,10806,5915,1489,9789,5942,10706, + 10431,7535,426,8974,3757,10314,9364,347,5868,9551,9634,6554,10596,9280,11566,174, + 2948,2503,6507,10723,11606,2459,64,3656,8455,5257,5919,7856,1747,9166,5486,9235, + 6065,835,3570,4240,11580,4046,10970,9139,1058,8210,11848,922,7967,1958,10211,1112, + 3728,4049,11130,5990,1404,325,948,11143,6190,295,11637,5766,8212,8273,2919,8527, + 6119,6992,8333,1360,2555,6167,1200,7105,7991,3329,9597,12121,5106,5961,10695,10327, + 3051,9923,4896,9326,81,3091,1000,7969,4611,726,1853,12149,4255,11112,2768,10654, + 1062,2294,3553,4805,2747,4846,8577,9154,1170,2319,790,11334,9275,9088,1326,5086, + 9094,6429,11077,10643,3504,3542,8668,9744,1479,1,8246,7143,11567,10984,4134,5736, + 4978,10938,5777,8961,4591,5728,6461,5023,9650,7468,949,9664,2975,11726,2744,9283, + 10092,5067,12171,2476,3748,11336,6522,827,9452,5374,12159,7935,3296,3949,9893,4452, + 10908,2525,3584,8112,8011,10616,4989,6958,11809,9447,12280,1022,11950,9821,11745,5791, + 5092,2089,9005,2881,3289,2013,9048,729,7901,1260,5755,4632,11955,2426,10593,1428, + 4890,5911,3932,9558,8830,3637,5542,145,5179,8595,3707,10530,355,3382,4231,9741, + 1207,9041,7012,1168,10146,11224,4645,11885,10911,10377,435,7952,4096,493,9908,6845, + 6039,2422,2187,9723,8643,9852,9302,6022,7278,1002,4284,5088,1607,7313,875,8509, + 9430,1045,2481,5012,7428,354,6591,9377,11847,2401,1067,7188,11516,390,8511,8456, + 7270,545,8585,9611,12047,1537,4143,4714,4885,1017,5084,1632,3066,27,1440,8526, + 9273,12046,11618,9289,3400,9890,3136,7098,8758,11813,7384,3985,11869,6730,10745,10111, + 2249,4048,2884,11136,2126,1630,9103,5407,2686,9042,2969,8311,9424,9919,8779,5332, + 10626,1777,4654,10863,7351,3636,9585,5291,8374,2166,4919,12176,9140,12129,7852,12286, + 4895,10805,2780,5195,2305,7247,9644,4053,10600,3364,3271,4057,4414,9442,7917,2174, + 3947,11951,2455,6599,10545,10975,3654,2894,7681,7126,7287,12269,4119,3343,2151,1522, + 7174,7350,11041,2442,2148,5959,6492,8330,8945,5598,3624,10397,1325,6565,1945,11260, + 10077,2674,3338,3276,11034,506,6505,1392,5478,8778,1178,2776,3408,10347,11124,2575, + 9489,12096,6092,10058,4167,6085,923,11251,11912,4578,10669,11914,425,10453,392,10104, + 8464,4235,8761,7376,2291,3375,7954,8896,6617,7790,1737,11667,3982,9342,6680,636, + 6825,7383,512,4670,2900,12050,7735,994,1687,11883,7021,146,10485,1403,5189,6094, + 2483,2054,3042,10945,3981,10821,11826,8882,8151,180,9600,7684,5219,10880,6780,204, + 11232,2600,7584,3121,3017,11053,7814,7043,4251,4739,11063,6771,7073,9261,2360,11925, + 1928,11825,8024,3678,3205,3359,11197,5209,8581,3238,8840,1136,9363,1826,3171,4489, + 7885,346,2068,1389,8257,3163,4840,6127,8062,8921,612,4238,10763,8067,125,11749, + 10125,5416,2110,716,9839,10584,11475,11873,3448,343,1908,4538,10423,7078,4727,1208, + 11572,3589,2982,1373,1721,10753,4103,2429,4209,5412,5993,9011,438,3515,7228,1218, + 8347,5232,8682,1327,7508,4924,448,1014,10029,12221,4566,5836,12229,2717,1535,3200, + 5588,5845,412,5102,7326,3744,3056,2528,7406,8314,9202,6454,6613,1417,10032,7784, + 1518,3765,4176,5063,9828,2275,6636,4267,6463,2065,7725,3495,8328,8755,8144,10533, + 5966,12077,9175,9520,5596,6302,8400,579,6781,11014,5734,11113,11164,4860,1131,10844, + 9068,8016,9694,3837,567,9348,7000,6627,7699,5082,682,11309,5207,4050,7087,844, + 7434,3769,293,9057,6940,9344,10883,2633,8190,3944,5530,5604,3480,2171,9282,11024, + 2213,8136,3805,767,12239,216,11520,6763,10353,7,8566,845,7235,3154,4360,3285, + 10268,2832,3572,1282,7559,3229,8360,10583,6105,3120,6643,6203,8536,8348,6919,3536, + 9199,10891,11463,5043,1658,5618,8787,5789,4719,751,11379,6389,10783,3065,7806,6586, + 2622,5386,510,7628,6921,578,10345,11839,8929,4684,12226,7154,9916,7302,8481,3670, + 11066,2334,1590,7878,10734,1802,1891,5103,6151,8820,3418,7846,9951,4693,417,9996, + 9652,4510,2946,5461,365,881,1927,1015,11675,11009,1371,12265,2485,11385,5039,6742, + 8449,1842,12217,8176,9577,4834,7937,9461,2643,11194,3045,6508,4094,3451,7911,11048, + 5406,4665,3020,6616,11345,7519,3669,5287,1790,7014,5410,11038,11249,2035,6125,10407, + 4565,7315,5078,10506,2840,2478,9270,4194,9195,4518,7469,1160,6878,2730,10421,10036, + 1734,3815,10939,5832,10595,10759,4423,8420,9617,7119,11010,11424,9173,189,10080,10526, + 3466,10588,7592,3578,11511,7785,9663,530,12150,8957,2532,3317,9349,10243,1481,9332, + 3454,3758,7899,4218,2593,11410,2276,982,6513,1849,8494,9021,4523,7988,8,457, + 648,150,8000,2307,2301,874,5650,170,9462,2873,9855,11498,2535,11169,5808,12268, + 9687,1901,7171,11787,3846,1573,6063,3793,466,11259,10608,3821,6320,4649,6263,2929] + + +-- | inverses of powers of nth root of -1 +-- divided by n in Montgomery domain with R=2^18 +ψInvMontgomery :: N -> VU.Vector Word16 +ψInvMontgomery n = case n of + N512 -> ψInvMontgomery512 + N1024 -> ψInvMontgomery1024 + + +-- | inverse ψ table for N512 +ψInvMontgomery512 :: VU.Vector Word16 +ψInvMontgomery512 = VU.fromList [ 512,3944,4267,5411,9615,5900,3205,6063,9261,2021,3087,4770,1029,1590,343,530, + 8307,4273,2769,9617,923,7302,4404,2434,1468,9004,8682,11194,2894,11924,5061,8071, + 1687,10883,8755,7724,11111,6671,7800,6320,2600,6203,4963,6164,9847,6151,11475,10243, + 3825,11607,1275,3869,425,5386,4238,9988,5509,11522,10029,7937,3343,6742,9307,10440, + 11295,3480,3765,1160,1255,4483,8611,9687,11063,3229,7784,9269,6691,7186,10423,10588, + 11667,11722,3889,12100,9489,12226,3163,12268,9247,12282,11275,4094,11951,5461,8080,10013, + 10886,7434,7725,2478,2575,826,9051,8468,3017,6919,5102,10499,5797,7596,10125,2532, + 3375,844,1125,8474,375,6921,125,2307,4138,769,9572,8449,7287,11009,2429,7766, + 4906,6685,9828,10421,3276,7570,1092,10716,364,3572,8314,5287,10964,9955,7751,11511, + 6680,3837,6323,1279,6204,8619,2068,2873,8882,5054,7057,5781,10545,1927,3515,8835, + 5268,2945,1756,5078,8778,5789,2926,6026,9168,6105,3056,2035,5115,8871,1705,2957, + 8761,5082,11113,1694,11897,4661,8062,5650,10880,10076,7723,7455,10767,2485,3589,9021, + 9389,3007,7226,9195,6505,3065,10361,5118,7550,1706,6613,4665,10397,1555,7562,8711, + 6617,7000,6302,10526,6197,7605,6162,2535,2054,845,4781,4378,5690,9652,5993,11410, + 6094,11996,10224,8095,3408,10891,1136,11823,4475,3941,5588,5410,5959,9996,10179,3332, + 3393,5207,1131,5832,377,1944,4222,648,9600,216,3200,72,5163,24,1721,8, + 4670,4099,5653,9559,10077,11379,3359,3793,5216,9457,5835,11345,1945,7878,8841,2626, + 2947,9068,9175,7119,11251,2373,11943,791,3981,4360,1327,9646,8635,11408,11071,7899, + 11883,2633,3961,4974,9513,1658,3171,4649,1057,5646,8545,1882,11041,8820,11873,2940, + 8054,980,6781,4423,10453,9667,11677,11415,12085,3805,12221,9461,8170,7250,10916,6513, + 7735,2171,10771,4820,11783,5703,8024,1901,6771,4730,2257,5673,8945,1891,7078,8823, + 10552,2941,11710,9173,12096,7154,4032,6481,1344,10353,448,3451,8342,9343,6877,11307, + 10485,3769,3495,9449,1165,7246,8581,10608,11053,3536,11877,5275,3959,9951,5416,3317, + 9998,5202,7429,1734,10669,578,11749,4289,12109,5526,12229,1842,12269,614,8186,4301, + 6825,5530,2275,10036,8951,11538,7080,3846,2360,1282,4883,8620,5724,11066,1908,7785, + 636,2595,212,865,4167,8481,1389,2827,463,9135,8347,3045,10975,1015,11851,8531, + 12143,6940,8144,10506,6811,3502,10463,9360,7584,3120,2528,1040,4939,4443,9839,1481, + 7376,4590,6555,1530,2185,510,8921,170,7070,4153,6453,9577,2151,11385,717,3795, + 239,1265,4176,4518,1392,1506,464,502,4251,8360,1417,6883,8665,10487,11081,7592, + 7790,6627,6693,2209,2231,8929,4840,11169,9806,3723,7365,1241,2455,4510,9011,9696, + 7100,3232,6463,9270,10347,3090,3449,1030,5246,8536,5845,11038,10141,11872,11573,12150, + 7954,4050,10844,1350,7711,450,10763,150,7684,50,10754,4113,7681,1371,10753,457] + +-- | inverse ψ table for N1024 +ψInvMontgomery1024 :: VU.Vector Word16 +ψInvMontgomery1024 = VU.fromList [ 256,10570,1510,7238,1034,7170,6291,7921,11665,3422,4000,2327,2088,5565,795,10647, + 1521,5484,2539,7385,1055,7173,8047,11683,1669,1994,3796,5809,4341,9398,11876,12230, + 10525,12037,12253,3506,4012,9351,4847,2448,7372,9831,3160,2207,5582,2553,7387,6322, + 9681,1383,10731,1533,219,5298,4268,7632,6357,9686,8406,4712,9451,10128,4958,5975, + 11387,8649,11769,6948,11526,12180,1740,10782,6807,2728,7412,4570,4164,4106,11120,12122, + 8754,11784,3439,5758,11356,6889,9762,11928,1704,1999,10819,12079,12259,7018,11536,1648, + 1991,2040,2047,2048,10826,12080,8748,8272,8204,1172,1923,7297,2798,7422,6327,4415, + 7653,6360,11442,12168,7005,8023,9924,8440,8228,2931,7441,1063,3663,5790,9605,10150, + 1450,8985,11817,10466,10273,12001,3470,7518,1074,1909,7295,9820,4914,702,5367,7789, + 8135,9940,1420,3714,11064,12114,12264,1752,5517,9566,11900,1700,3754,5803,829,1874, + 7290,2797,10933,5073,7747,8129,6428,6185,11417,1631,233,5300,9535,10140,11982,8734, + 8270,2937,10953,8587,8249,2934,9197,4825,5956,4362,9401,1343,3703,529,10609,12049, + 6988,6265,895,3639,4031,4087,4095,585,10617,8539,4731,4187,9376,3095,9220,10095, + 10220,1460,10742,12068,1724,5513,11321,6884,2739,5658,6075,4379,11159,10372,8504,4726, + 9453,3106,7466,11600,10435,8513,9994,8450,9985,3182,10988,8592,2983,9204,4826,2445, + 5616,6069,867,3635,5786,11360,5134,2489,10889,12089,1727,7269,2794,9177,1311,5454, + 9557,6632,2703,9164,10087,1441,3717,531,3587,2268,324,5313,759,1864,5533,2546, + 7386,9833,8427,4715,11207,1601,7251,4547,11183,12131,1733,10781,10318,1474,10744,5046, + 4232,11138,10369,6748,964,7160,4534,7670,8118,8182,4680,11202,6867,981,8918,1274, + 182,26,7026,8026,11680,12202,10521,1503,7237,4545,5916,9623,8397,11733,10454,3249, + 9242,6587,941,1890,270,10572,6777,9746,6659,6218,6155,6146,878,1881,7291,11575, + 12187,1741,7271,8061,11685,6936,4502,9421,4857,4205,7623,1089,10689,1527,8996,10063, + 11971,10488,6765,2722,3900,9335,11867,6962,11528,5158,4248,4118,5855,2592,5637,6072, + 2623,7397,8079,9932,4930,5971,853,3633,519,8852,11798,3441,11025,1575,225,8810, + 11792,12218,3501,9278,3081,9218,4828,7712,8124,11694,12204,3499,4011,573,3593,5780, + 7848,9899,10192,1456,208,7052,2763,7417,11593,10434,12024,8740,11782,10461,3250,5731, + 7841,9898,1414,202,3540,7528,2831,2160,10842,5060,4234,4116,588,84,12,7024, + 2759,9172,6577,11473,1639,9012,3043,7457,6332,11438,1634,1989,9062,11828,8712,11778, + 12216,10523,6770,9745,10170,4964,9487,6622,946,8913,6540,6201,4397,9406,8366,9973, + 8447,8229,11709,8695,10020,3187,5722,2573,10901,6824,4486,4152,9371,8361,2950,2177, + 311,1800,9035,8313,11721,3430,490,70,10,1757,251,3547,7529,11609,3414,7510, + 4584,4166,9373,1339,5458,7802,11648,1664,7260,9815,10180,6721,9738,10169,8475,8233, + 9954,1422,8981,1283,5450,11312,1616,3742,11068,10359,4991,713,3613,9294,8350,4704, + 672,96,7036,9783,11931,3460,5761,823,10651,12055,10500,1500,5481,783,3623,11051, + 8601,8251,8201,11705,10450,5004,4226,7626,2845,2162,3820,7568,9859,3164,452,10598, + 1514,5483,6050,6131,4387,7649,8115,6426,918,8909,8295,1185,5436,11310,8638,1234, + 5443,11311,5127,2488,2111,10835,5059,7745,2862,3920,560,80,1767,2008,3798,11076, + 6849,2734,10924,12094,8750,1250,10712,6797,971,7161,1023,8924,4786,7706,4612,4170, + 7618,6355,4419,5898,11376,10403,10264,6733,4473,639,5358,2521,9138,3061,5704,4326, + 618,5355,765,5376,768,7132,4530,9425,3102,9221,6584,11474,10417,10266,12000,6981, + 6264,4406,2385,7363,4563,4163,7617,9866,3165,9230,11852,10471,5007,5982,11388,5138, + 734,3616,11050,12112,6997,11533,12181,10518,12036,3475,2252,7344,9827,4915,9480,6621, + 4457,7659,9872,6677,4465,4149,7615,4599,657,3605,515,10607,6782,4480,640,1847, + 3775,5806,2585,5636,9583,1369,10729,8555,10000,11962,5220,7768,8132,8184,9947,1421, + 203,29,8782,11788,1684,10774,10317,4985,9490,8378,4708,11206,5112,5997,7879,11659, + 12199,8765,10030,4944,5973,6120,6141,6144,7900,11662,1666,238,34,3516,5769,9602, + 8394,9977,6692,956,10670,6791,9748,11926,8726,11780,5194,742,106,8793,10034,3189, + 10989,5081,4237,5872,4350,2377,10873,6820,6241,11425,10410,10265,3222,5727,9596,4882, + 2453,2106,3812,11078,12116,5242,4260,11142,8614,11764,12214,5256,4262,4120,11122,5100, + 11262,5120,2487,5622,9581,8391,8221,2930,10952,12098,6995,6266,9673,4893,699,3611, + 4027,5842,11368,1624,232,8811,8281,1183,169,8802,3013,2186,5579,797,3625,4029, + 11109,1587,7249,11569,8675,6506,2685,10917,12093,12261,12285,1755,7273,1039,1904,272, + 3550,9285,3082,5707,6082,4380,7648,11626,5172,4250,9385,8363,8217,4685,5936,848, + 8899,6538,934,1889,3781,9318,10109,10222,6727,961,5404,772,5377,9546,8386,1198, + 8949,3034,2189,7335,4559,5918,2601,10905,5069,9502,3113,7467,8089,11689,5181,9518, + 8382,2953,3933,4073,4093,7607,8109,2914,5683,4323,11151,1593,10761,6804,972,3650, + 2277,5592,4310,7638,9869,4921,703,1856,9043,4803,9464,1352,8971,11815,5199,7765, + 6376,4422,7654,2849,407,8836,6529,7955,2892,9191,1313,10721,12065,12257,1751,9028, + 8312,2943,2176,3822,546,78,8789,11789,10462,12028,6985,4509,9422,1346,5459,4291, + 613,10621,6784,9747,3148,7472,2823,5670,810,7138,8042,4660,7688,6365,6176,6149, + 2634,5643,9584,10147,11983,5223,9524,11894,10477,8519,1217,3685,2282,326,10580,3267, + 7489,4581,2410,5611,11335,6886,8006,8166,11700,3427,11023,8597,10006,3185,455,65, + 5276,7776,4622,5927,7869,9902,11948,5218,2501,5624,2559,10899,1557,1978,10816,10323, + 8497,4725,675,1852,10798,12076,10503,3256,9243,3076,2195,10847,12083,10504,12034,10497] diff --git a/src/Crypto/NewHope/RNG.hs b/src/Crypto/NewHope/RNG.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/RNG.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.RNG + Description : Pseudorandom number generation for NewHope + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Pseudorandom number generation for NewHope. + + This module contains the public interface. Implementation definitions + are in the "Crypto.NewHope.Internal.RNG" module. + +-} + +module Crypto.NewHope.RNG ( Context + , RandomSeedable + , makeRandomSeed + , randomBytesInit + , randomBytes + ) where + + +import Crypto.NewHope.Internal.RNG diff --git a/src/Crypto/NewHope/Reduce.hs b/src/Crypto/NewHope/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Reduce.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.Reduce + Description : Montgomery reduction for use in polynomial multiplication. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + See https://en.wikipedia.org/wiki/Montgomery_modular_multiplication + +-} + +module Crypto.NewHope.Reduce (montgomeryReduce) where + +import Data.Bits +import Data.ByteString.Builder (toLazyByteString, word32BE) +import Data.ByteString.Lazy (unpack) +import Data.Word + +import qualified Crypto.NewHope.Internals as Internals (q) + +qinv :: Word32 +qinv = 12287 -- inverse_mod(p,2^18) + + +rlog :: Int +rlog = 18 + +-- low 16 bits, bigendianly, of a 32 bit word +low16 :: Word32 -> Word16 +low16 n = shiftL hb 8 + lb where + bytes = drop 2 $ unpack $ toLazyByteString $ word32BE n + hb = fromIntegral (bytes !! 0) + lb = fromIntegral (bytes !! 1) + + +montgomeryReduce :: Word32 -> Word16 +montgomeryReduce a = low16 result + where + u = a * qinv + u' = u .&. (shiftL 1 rlog - 1 ) + u'' = u' * fromIntegral Internals.q + a' = a + u'' + result = shiftR a' rlog diff --git a/src/Crypto/NewHope/SeedExpander.hs b/src/Crypto/NewHope/SeedExpander.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/SeedExpander.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.SeedExpander + Description : Seed expander for NewHope. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + The "seed expander" is a facility specified by NIST for generating + pseudorandom data given a seed. It is not used in the actual NewHope + key exchange and is provided here for completeness/isomorphism with + the NewHope C reference library. + + This module contains the public interface. Implementation definitions + are in the "Crypto.NewHope.Internal.SeedExpander" module. + + * Sample usage + + @ + let maxLen' = case maxLen 256 of Right value -> value + Left x -> error (show x) + + let diversifier = case createDiversifier (BSC.pack "12345678") of Right value -> value + Left x -> error (show x) + + let seed = (Internals.makeSeed "32 bytes of seed data go here...") + + let ctx = case seedexpanderInit seed diversifier maxLen' of Right value -> value + Left x -> error (show x) + + let (ctx', buf) = case seedexpander ctx 16 of Right value -> value + Left x r -> error (show x) + @ + +-} + +module Crypto.NewHope.SeedExpander ( RNGError + -- * Preparing parameters + , makeSeed + , Seedable + + , maxLen + , createDiversifier + + -- * Expanding a seed + , seedexpanderInit + , seedexpander + + ) where + +import Crypto.NewHope.Internal.SeedExpander +import Crypto.NewHope.Internals (Seedable, makeSeed) diff --git a/src/Crypto/NewHope/Verify.hs b/src/Crypto/NewHope/Verify.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/NewHope/Verify.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-| + Module : Crypto.NewHope.Verify + Description : Constant-time comparison and possible copying for NewHope + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Constant time operations are important for protection against + timing-based attacks on cryptosystems. + + We implement two versions for possible copying, one which uses + mappend (and is valid for any Monoid) and the other which is + ByteString-specific and does actual bit operations. The code + currently just uses the first, but if we find a flaw with that then + we can switch to the second. + +-} + +module Crypto.NewHope.Verify where + +import Data.Bits +import qualified Data.ByteString as BS +import Data.Foldable +import Data.Semigroup (Semigroup, (<>)) + + + +-- We have tests which attempt to demonstrate that these functions +-- really do take constant time, but this should probably also be done +-- by examination of the Core generated, and the assembly generated +-- from that. + +-- | If the passed Bool is True, return the first of the following +-- arguments. If it is False, return the second of the following +-- arguments. Execution of this function should take constant time. +constantTimeChoose :: (Monoid a, Semigroup a) => Bool -> a -> a -> a +constantTimeChoose !v !a !b = (if v then a else mempty) <> (if v' then b else mempty) + where + !v' = not v + +-- | If the passed Bool is True, return the first of the +-- ByteStrings. If it is False, return the second of the ByteStrings. +-- Execution of this function should take constant time on the length +-- of the shortest of the two ByteStrings. +cmov :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString +cmov t !r !x = BS.pack $ BS.zipWith go r x + where + operate = (if t then 0x00 else 0xFF) .|. (if not t then 0xFF else 0x00) + go r' x' = r' `xor` ((x' `xor` r') .&. operate) + + +-- | In constant time, return True if the ByteStrings are equal and +-- False if they are not. +verify :: BS.ByteString -> BS.ByteString -> Bool +verify !a !b = Data.Foldable.foldl go True (BS.zip a b) + where + go accum (c, d) = (c == d) && accum diff --git a/src/MiscUtils.hs b/src/MiscUtils.hs new file mode 100644 --- /dev/null +++ b/src/MiscUtils.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : MiscUtils + Description : Miscellaneous utility + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer: : jeremy@bornstein.org + Stability : experimental + Portability : portable + + I guess it can't be truly miscellaneous because there is essentially + only one thing here. C'est la vie. + +-} + +module MiscUtils where + +import qualified Data.ByteString as BS +import qualified Data.Vector.Unboxed as VU + + +-- | Chunkable allows an ordered container of things to be chunked +-- into a list of smaller versions of that thing, each containing N of +-- them instead of the full amount. The final item may contain fewer. +-- That is to say, a list of integers can be transformed into a list +-- of lists of 8 integers each, etc. +class Chunkable a + where + chunk :: Int -> a -> [a] + + +instance VU.Unbox a => Chunkable (VU.Vector a) + where + chunk n v = if VU.null as + then [a] + else a : chunk n as + where + (a, as) = VU.splitAt n v + + +instance Chunkable BS.ByteString + where + chunk n bs = if BS.length bs == 0 + then [] + else a : chunk n as + where + (a, as) = BS.splitAt 2 bs + + +instance Chunkable [a] + where + chunk n list = if null as + then [a] + else a : chunk n as + where + (a, as) = splitAt n list diff --git a/src/StringUtils.hs b/src/StringUtils.hs new file mode 100644 --- /dev/null +++ b/src/StringUtils.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-| + Module : StringUtils + Description : String utilities for NewHope. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + String utilities for NewHope. + +-} + +module StringUtils where + +import qualified Data.ByteString as BS +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Semigroup ((<>)) +import Numeric + +import MiscUtils + + +-- | Pad a string to a given length +class Paddable a + where + pad :: Char -> Int -> a -> a + +instance Paddable String + where + pad char len str = let + remainder = mod (len - Prelude.length str) len + extra = replicate remainder char + in str ++ extra + +instance Paddable BS.ByteString + where + pad char len str = let + remainder = mod (len - BS.length str) len + extra = replicate remainder char + in str <> BSC.pack extra + + +-- | Convert from a readable hex representation to binary representation and vice-versa. +class HexStringable a where + hexStringToByteString :: a -> BS.ByteString + byteStringToHexString :: BS.ByteString -> a + stringToHexString :: String -> a + + +instance HexStringable BS.ByteString where + hexStringToByteString s = BSLC.toStrict . toLazyByteString $ builder + where + builder = foldr go (byteString BS.empty) $ BSC.unpack <$> chunk 2 s + go a builder' = newbuilder <> builder' + where + newbuilder = word8 . fst . head . readHex . take 2 $ a + + byteStringToHexString = BSL.toStrict . toLazyByteString . byteStringHex + stringToHexString = byteStringToHexString . BSC.pack + + +instance HexStringable BSL.ByteString where + hexStringToByteString s = BSLC.toStrict . toLazyByteString $ builder + where + strict = BSL.toStrict s + builder = foldr go (byteString BS.empty) $ BSC.unpack <$> chunk 2 strict + go a builder' = newbuilder <> builder' + where + newbuilder = word8 . fst . head . readHex . take 2 $ a + + byteStringToHexString = toLazyByteString . byteStringHex + stringToHexString = byteStringToHexString . BSC.pack + + +instance HexStringable String where + + hexStringToByteString s = BSL.toStrict . toLazyByteString $ builder + where + builder = foldr go (byteString BS.empty) $ chunk 2 s + go a builder' = newbuilder <> builder' + where + newbuilder = word8 . fst . head . readHex . take 2 $ a + + byteStringToHexString = BSLC.unpack . toLazyByteString . byteStringHex + stringToHexString = BSLC.unpack . toLazyByteString . byteStringHex . BSC.pack + + +-- | Extract a range of bytes from a ByteString +bsRange :: BS.ByteString -> Int -> Int -> BS.ByteString +bsRange source offset len = (BS.take len . BS.drop offset) source + +-- | Compute a modification of input with a replacement overlaying the data at offset. +bsReplace :: BS.ByteString -> Int -> BS.ByteString -> BS.ByteString +bsReplace source offset new + | BS.length result /= BS.length source = error errorMsg + | otherwise = result + where + (initial, initialRest) = BS.splitAt offset source + final = BS.drop (BS.length new) initialRest + result = BS.append (BS.append initial new) final + sourceLength = BS.length source + newLength = BS.length new + errorMsg = "Source length " ++ show sourceLength + ++ "; replacement length: " ++ show newLength + ++ " ...looks like source is shorter than required" -- constants should prevent this diff --git a/test/ConfigFile.hs b/test/ConfigFile.hs new file mode 100644 --- /dev/null +++ b/test/ConfigFile.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : ConfigFile + Description : Loads and parses configuration files for NewHope testing code + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module ConfigFile where + +import Control.Applicative +import qualified Data.ByteString as BS +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Prelude hiding (map) +import Text.Trifecta + + +type Name = String +type Value = String +type Assignments = Map Name Value +newtype Header = Header String deriving (Eq, Ord, Show) +data Section = Section Header Assignments deriving (Eq, Show) +newtype Config = Config (Map Header Assignments) deriving (Eq, Show) + + +-- where our configuration files live +baseDirectory = "test/data/" -- ends with / +baseDirectory :: String + + +fromFile :: String -> IO Config +fromFile path = do let expandedPath = baseDirectory ++ path + fileContents <- BS.readFile expandedPath + let m = parseByteString parseIni mempty fileContents + case m of Success value -> return value + _ -> return $ Config M.empty + + +parseIni :: Parser Config +parseIni = do sections <- some parseSection + let mapOfSections = foldr rollup M.empty sections + return $ Config mapOfSections + where + rollup :: Section -> Map Header Assignments -> Map Header Assignments + rollup (Section h a) = M.insert h a + + +parseHeader :: Parser Header +parseHeader = parseBracketPair (Header <$> sectionIdentifier) + where + parseBracketPair :: Parser a -> Parser a + parseBracketPair p = char '[' *> p <* char ']' + + sectionIdentifier :: Parser String + sectionIdentifier = do initial <- letter + middle <- some letterOrSpecialChar + return $ initial : middle + where + letterOrSpecialChar :: CharParsing m => m Char + letterOrSpecialChar = char '_' <|> char '.' <|> alphaNum + + +skipEOL :: Parser () +skipEOL = skipMany (oneOf "\n") + + +parseSection :: Parser Section +parseSection = do + skipWhitespace + skipComments + h <- parseHeader + skipEOL + assignments <- some parseAssignment + return $ Section h (M.fromList assignments) + where + skipWhitespace :: Parser () + skipWhitespace = skipMany (char ' ' <|> char '\n') + + +skipComments :: Parser () +skipComments = skipMany (do _ <- char ';' <|> char '#' + skipMany (noneOf "\n") + skipEOL) + + +parseAssignment :: Parser (Name, Value) +parseAssignment = do name <- assignmentIdentifier + _ <- char '=' + val <- some (noneOf "\n") + skipEOL + return (name, val) + where + assignmentIdentifier :: (Monad m, CharParsing m) => m String + assignmentIdentifier = some $ char '_' <|> char '.' <|> alphaNum + + + +sectionNames :: Config -> [String] +sectionNames (Config map) = [go header | header <- M.keys map] + where + go (Header name) = name + + +sectionNamed :: Config -> String -> Assignments +sectionNamed (Config map) name = result -- map M.!? Header name + where + existing = map M.!? Header name + result = if isNothing existing + then M.empty + else let (Just innerResult) = existing + in innerResult + + +-- * Testing Utilities +-- The following functions are used by testing code once their files +-- have been loaded. + + +parseListWordIntegral :: Integral a => Parser [a] +parseListWordIntegral = do _ <- char '[' + result <- some parseIntAndMaybeComma + _ <- char ']' + return result + + +toIntegralList :: (Enum a, Integral b) => [a] -> [b] +toIntegralList = fmap (fromIntegral . fromEnum) + + +parseListIntegralPairs :: (Integral a, Integral b) => Parser [(a, b)] +parseListIntegralPairs = do _ <- char '[' + value <- some parsePairAndMaybeComma + _ <- char ']' + return value + where + parsePairAndMaybeComma :: (Integral a, Integral b) => Parser (a, b) + parsePairAndMaybeComma = do + _ <- char '(' + value <- integer + _ <- char ',' + value' <- integer + _ <- char ')' + _ <- option 'x' $ char ',' + return (fromIntegral value, fromIntegral value') + + +parseListIntegralMap :: (Integral a, Integral b) => Parser [(a, [b])] +parseListIntegralMap = do _ <- char '[' + item <- some parsePairAndMaybeComma + _ <- char ']' + return item + where + parsePairAndMaybeComma :: (Integral a, Integral b) => Parser (a, [b]) + parsePairAndMaybeComma = do _ <- char '(' + key <- integer + _ <- char ',' + _ <- char '[' + values <- some parseIntAndMaybeComma + _ <- char ']' + _ <- char ')' + _ <- option 'x' $ char ',' + return (fromIntegral key, values) + + +parseIntAndMaybeComma :: Integral a => Parser a +parseIntAndMaybeComma = do value <- integer + _ <- option 'x' $ char ',' + return $ fromIntegral value diff --git a/test/Crypto/NewHope/Test/CCA_KEM.hs b/test/Crypto/NewHope/Test/CCA_KEM.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/CCA_KEM.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.CCA_KEM + Description : Tests for IND-CCA-secure operations for NewHope + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer: : jeremy@bornstein.org + Stability : experimental + Portability : portable + + These tests duplicate (and in some cases improve on) the CCA tests + executed by the "test_*" binaries from the reference C code. + +-} + +module Crypto.NewHope.Test.CCA_KEM where + +import Control.Parallel +import System.CPUTime +import Test.Tasty (TestTree, adjustOption, testGroup) +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC hiding (output) + + +import AuxUtil +import qualified Crypto.NewHope.Internal.CCA_KEM as CCA_KEM +import qualified Crypto.NewHope.Internal.RNG as RNG +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.Test.RNG +import Statistics +import Util + + +-- | How many keypairs we use for timing analysis +keypairsToTestForTiming :: Int +keypairsToTestForTiming = 100 + + +-- | Test the basic key exchange. Note that we use multiple ctx on +-- input, which is an improvement (and more realistic test) as +-- compared to the reference code +propKeyExchange :: WrapN -> WrapContext -> WrapContext -> Bool +propKeyExchange wrappedN wrappedCtx wrappedCtx2 = success && keyA == keyB + where + WrapN n = wrappedN + WrapContext ctx = wrappedCtx + WrapContext ctx2 = wrappedCtx2 + + (pk, skA, _ctx') = CCA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CCA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + (success, keyA) = CCA_KEM.decrypt sendb skA -- Alice uses Bob's response to get her secret key + + +-- | Test that using random data as the secret key causes the key +-- exchange to fail. This is the test from the reference code. +propInvalidSkA :: WrapN -> WrapContext -> WrapContext -> WrapContext -> Bool +propInvalidSkA wn wctx wctx2 wctx3 = not success && keyA /= keyB + where + WrapN n = wn + WrapContext ctx = wctx + WrapContext ctx2 = wctx2 + WrapContext ctx3 = wctx3 + + (pk, _skA, _ctx') = CCA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CCA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + (success, keyA) = CCA_KEM.decrypt sendb skA' -- Alice uses Bob's response to get her secret key + where + skA' = CCA_KEM.SecretKey randomData -- Replace secret key with random values + (randomData, _ctx'3) = RNG.randomBytes ctx3 $ CCA_KEM.secretKeyBytes n + + +-- | Test to see if mutating a certain number of bits in the secret key causes the +-- key exchange to fail. (It only does sometimes until we get to 3 bits, when it does.) +propInvalidSkAMutateNBits :: Int -> WrapN -> WrapContext -> WrapContext -> Bool +propInvalidSkAMutateNBits bits wn wctx wctx2 = not success && keyA /= keyB + where + WrapN n = wn + WrapContext ctx = wctx + WrapContext ctx2 = wctx2 + + (pk, skA, ctx') = CCA_KEM.keypair ctx n -- Alice generates a public key + (skA', _ctx'2) = mutateSecretKeyBits ctx' bits skA -- Change one or more bits in the secret key + (sendb, keyB, _ctx2') = CCA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + (success, keyA) = CCA_KEM.decrypt sendb skA' -- Alice tries to use Bob's response to get her secret key + + +-- | Does randomly mutating one or more bits in the ciphertext cause +-- the decryption to fail? It does, even at one bit. +propInvalidCiphertextMutateNBits :: Int -> WrapN -> WrapContext -> WrapContext -> WrapContext -> Bool +propInvalidCiphertextMutateNBits bits wn wctx wctx2 wctx3 = not success && keyA /= keyB + where + WrapN n = wn + WrapContext ctx = wctx + WrapContext ctx2 = wctx2 + WrapContext ctx3 = wctx3 + + (pk, skA, _ctx') = CCA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CCA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + (sendb', _ctx'3) = mutateCipherTextBits ctx3 bits sendb -- Change some byte in the ciphertext (i.e., encapsulated key) + (success, keyA) = CCA_KEM.decrypt sendb' skA -- Alice uses the damaged version of Bob's response to get her secret key + + +-- | A TimingPair is a list of computations, the first of each which +-- is a prerequisite for the second. This is used to help isolate the +-- functions which we wish to time. +newtype TimingPair a b = TimingPair (a, b) + + +-- An infinite list of keypairs and accompanying ctx +keypairsWithCtx :: Internals.N -> [(CCA_KEM.PublicKey, CCA_KEM.SecretKey, RNG.Context)] +keypairsWithCtx n = go initialCtx + where + initialSeed = RNG.makeRandomSeed "Assise en tailleur face à l'écran, Nadine appuie" + initialCtx = RNG.randomBytesInit initialSeed Nothing 0 + go ctx = (nextPk, nextSk, ctx') : go ctx' + where + (nextPk, nextSk, ctx') = CCA_KEM.keypair ctx n + + +mutateCipherTextBits :: RNG.Context -> Int -> CCA_KEM.CipherText -> (CCA_KEM.CipherText, RNG.Context) +mutateCipherTextBits ctx count (CCA_KEM.CipherText input) = (CCA_KEM.CipherText output, ctx') + where + (output, ctx') = mutateBits ctx count input + +mutateSecretKeyBits :: RNG.Context -> Int -> CCA_KEM.SecretKey -> (CCA_KEM.SecretKey, RNG.Context) +mutateSecretKeyBits ctx count (CCA_KEM.SecretKey input) = (CCA_KEM.SecretKey output, ctx') + where + (output, ctx') = mutateBits ctx count input + + +assertKeyExchangeTiming :: IO Bool +assertKeyExchangeTiming = runTimingTests timingPairs + where + timingPairs = pairFor <$> take keypairsToTestForTiming (keypairsWithCtx Internals.N1024) + where + pairFor (pk, skA, ctx) = (TimingPair (prereqA, funcA), TimingPair (prereqB, funcB)) + where + + (!sendb, _keyB, ctx'2) = CCA_KEM.encrypt ctx pk -- Bob derives a secret key and creates a response + (!sendb', _ctx'3) = mutateCipherTextBits ctx'2 1 sendb -- alternate version of sendb to use for a bad decryption + + prereqA = (sendb, skA) -- Alice uses Bob's response to get her secret key + funcA = CCA_KEM.decrypt sendb skA + + prereqB = (sendb', skA) -- Alice tries, but Bob's response is bad. + funcB = CCA_KEM.decrypt sendb' skA + + runTimingTests testPairs = do allTimes <- traverse getTimeDifference testPairs + let (low, high) = confidence 0.95 allTimes + -- TODO: just checking for 0 being included in the confidence interval is stupidly insufficient. + -- we should also check to see that the confidence interval is sufficiently narrow. but how narrow + -- is appropriate? + return $ (low < 0) && (high > 0) + where + -- value returned represents the difference between measurement A and measurement B for a paired observation. + getTimeDifference (TimingPair (prereqA, funcA), TimingPair (prereqB, funcB)) = do + start1 <- pseq prereqA getCPUTime + time1 <- pseq funcA getCPUTime + start2 <- pseq prereqB getCPUTime + time2 <- pseq funcB getCPUTime + let time1' = time1 - start1 + let time2' = time2 - start2 + return (time1' - time2') + + +tests :: IO TestTree +tests = do + assertKeyExchangeTiming' <- assertKeyExchangeTiming + + return $ testGroup "CCA_KEM Tests" [ QC.testProperty "top level key exchange" propKeyExchange + , QC.testProperty "invalid skA" propInvalidSkA + , expectFail $ adjustOption (\ _ -> QuickCheckTests 256) $ QC.testProperty "invalid skA (one random bit changed)" $ propInvalidSkAMutateNBits 1 + , QC.testProperty "invalid skA (two random bits changed)" $ propInvalidSkAMutateNBits 2 + , QC.testProperty "invalid skA (three random bits changed)" $ propInvalidSkAMutateNBits 3 + , adjustOption (\ _ -> QuickCheckTests 256) $ QC.testProperty "invalid ciphertext (one random bit changed)" $ propInvalidCiphertextMutateNBits 1 + , adjustOption (\ _ -> QuickCheckTests 4192) $ QC.testProperty "invalid ciphertext (two random bits changed)" $ propInvalidCiphertextMutateNBits 2 + , testCase "top level key exchange timing" (assertBool "relative timing not acceptable" assertKeyExchangeTiming') + ] diff --git a/test/Crypto/NewHope/Test/CPA_KEM.hs b/test/Crypto/NewHope/Test/CPA_KEM.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/CPA_KEM.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.CPA_KEM + Description : Tests for IND-CPA-secure operations for NewHope. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + These tests duplicate (and in some cases improve on) the CPA tests + executed by the "test_*" binaries from the reference C code. + +-} + +module Crypto.NewHope.Test.CPA_KEM where + + +import Data.Bits +import qualified Data.ByteString as BS +import Test.Tasty (TestTree, adjustOption, testGroup) +import Test.Tasty.ExpectedFailure +import Test.Tasty.QuickCheck as QC hiding (output) + + +import AuxUtil +import qualified Crypto.NewHope.Internal.CPA_KEM as CPA_KEM +import qualified Crypto.NewHope.Internal.RNG as RNG +import qualified Crypto.NewHope.Internals () +import Crypto.NewHope.Test.RNG +import Util + + +-- Test the basic full key exchange. Note that we use multiple ctx on +-- input, which is an improvement (and more realistic) as compared to +-- the reference code. +propKeyExchange :: WrapN -> WrapContext -> WrapContext -> Bool +propKeyExchange wrappedN wrappedCtx wrappedCtx2 = keyA == keyB + where + WrapN n = wrappedN + WrapContext ctx = wrappedCtx + WrapContext ctx2 = wrappedCtx2 + + (pk, skA, _ctx') = CPA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CPA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + keyA = CPA_KEM.decrypt sendb skA -- Alice uses Bob's response to get her secret key + + +-- Test that using random data as the secret key causes the key exchange to fail. +propInvalidSkA :: WrapN -> WrapContext -> WrapContext -> WrapContext -> Bool +propInvalidSkA wn wctx wctx2 wctx3 = keyA /= keyB + where + WrapN n = wn + WrapContext ctx = wctx + WrapContext ctx2 = wctx2 + WrapContext ctx3 = wctx3 + + (pk, _skA, _ctx') = CPA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CPA_KEM.encrypt ctx2 pk -- Bob derives the SharedSecret and creates a response + keyA = CPA_KEM.decrypt sendb skA' -- Alice tries to use Bob's response to get the SharedSecret + where + (randomData, _ctx'3) = RNG.randomBytes ctx3 $ CPA_KEM.secretKeyBytes n + skA' = CPA_KEM.SecretKey randomData -- Replace secret key with random values + + +-- | Test that the key exchange fails if three bits in the CipherText +-- are changed. This test (mirroring the reference C implementation) +-- changes the same three bits each time. An improved version of the +-- test would probably change three different bits. +propInvalidCiphertext :: WrapN -> WrapContext -> WrapContext -> Bool +propInvalidCiphertext wn wctx wctx2 = keyA /= keyB + where + WrapN n = wn + WrapContext ctx = wctx + WrapContext ctx2 = wctx2 + + (pk, skA, _ctx') = CPA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CPA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + sendb' = mutateCipherText sendb -- alternate version of sendb to use for a bad decryption + keyA = CPA_KEM.decrypt sendb' skA -- Alice tries to use Bob's response to get her secret key + + +-- | Change three bits (always the same three) in the input +-- CipherText. This is the test from the reference library. +mutateCipherText :: CPA_KEM.CipherText -> CPA_KEM.CipherText +mutateCipherText (CPA_KEM.CipherText input) = CPA_KEM.CipherText output + where + (part1, part2) = BS.splitAt 42 input + (part2a, part2b) = BS.splitAt 1 part2 + part2a' = BS.pack [xor (BS.index part2a 0) 0x23] + output = BS.concat [part1, part2a', part2b] + + +-- | Each time, randomly mutate some number of bits in the ciphertext. +propInvalidCiphertextMutateNBits :: Int -> WrapN -> WrapContext -> WrapContext -> WrapContext -> Bool +propInvalidCiphertextMutateNBits bits wn wctx wctx2 wctx3 = keyA /= keyB + where + WrapN n = wn + WrapContext ctx = wctx + WrapContext ctx2 = wctx2 + WrapContext ctx3 = wctx3 + + (pk, skA, _ctx') = CPA_KEM.keypair ctx n -- Alice generates a public key + (sendb, keyB, _ctx'2) = CPA_KEM.encrypt ctx2 pk -- Bob derives a secret key and creates a response + (sendb', _ctx'3) = mutateCipherTextBits ctx3 bits sendb -- Change some byte in the ciphertext (i.e., encapsulated key) + keyA = CPA_KEM.decrypt sendb' skA -- Alice uses the damaged version of Bob's response to get her secret key + + +mutateCipherTextBits :: RNG.Context -> Int -> CPA_KEM.CipherText -> (CPA_KEM.CipherText, RNG.Context) +mutateCipherTextBits ctx count (CPA_KEM.CipherText input) = (CPA_KEM.CipherText output, ctx') + where + (output, ctx') = mutateBits ctx count input + + +tests :: TestTree +tests = testGroup "CPA_KEM Tests" [ QC.testProperty "top level key exchange" propKeyExchange + , QC.testProperty "invalid skA" propInvalidSkA + , QC.testProperty "invalid ciphertext" propInvalidCiphertext + , expectFail + $ adjustOption (\ _ -> QuickCheckTests 256) + $ QC.testProperty "invalid ciphertext (one random bit changed)" + $ propInvalidCiphertextMutateNBits 1 + , expectFail + $ adjustOption (\ _ -> QuickCheckTests 256) + $ QC.testProperty "invalid ciphertext (two random bits changed)" + $ propInvalidCiphertextMutateNBits 2 + , expectFail + $ adjustOption (\ _ -> QuickCheckTests 512) + $ QC.testProperty "invalid ciphertext (three random bits changed)" + $ propInvalidCiphertextMutateNBits 3 + , expectFail + $ adjustOption (\ _ -> QuickCheckTests 3200) + $ QC.testProperty "invalid ciphertext (four random bits changed)" + $ propInvalidCiphertextMutateNBits 4 + , QC.testProperty "invalid ciphertext (five random bits changed)" $ propInvalidCiphertextMutateNBits 5 + ] + + diff --git a/test/Crypto/NewHope/Test/FIPS202.hs b/test/Crypto/NewHope/Test/FIPS202.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/FIPS202.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.FIPS202 + Description : Testing code for NewHope.FIPS202 (an implementation of Keccak/SHA-3) + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.FIPS202 where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Map as Map +import qualified Data.Vector.Unboxed as VU +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit +import Text.Trifecta hiding (count) + +import ConfigFile +import Crypto.NewHope.FIPS202 +import StringUtils + + +-- all the validation data for these tests +configFile :: IO Config +configFile = fromFile "FIPS202.cfg" + + +data StatePermuteValidationParams = StatePermuteValidationParams { keccakInput :: VU.Vector Word64 + , keccakOutput :: VU.Vector Word64 + } deriving Show + +keccakFromConfig :: Assignments -> StatePermuteValidationParams +keccakFromConfig section = StatePermuteValidationParams { keccakInput = inputVector, keccakOutput = outputVector } + where + Text.Trifecta.Success input = parseString parseListWordIntegral mempty $ section Map.! "input" + inputVector = VU.fromList input + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section Map.! "output" + outputVector = VU.fromList output + +keccakPermuteCheck :: StatePermuteValidationParams -> TestTree +keccakPermuteCheck params = testCase "keccakf1600_permute" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = keccakOutput params + calculatedResult = keccakF1600StatePermute $ keccakInput params + + +data Shake128AbsorbValidationParams = Shake128AbsorbValidationParams { absorbSeed :: BS.ByteString + , absorbState :: [Word64] + } deriving Show + +absorbStateVector :: Shake128AbsorbValidationParams -> VU.Vector Word64 +absorbStateVector params = VU.fromList $ absorbState params + +absorbFromConfig :: Assignments -> Shake128AbsorbValidationParams +absorbFromConfig section = Shake128AbsorbValidationParams { absorbSeed = seed, absorbState = state } + where + seed = BSC.pack $ section Map.! "seed" + Text.Trifecta.Success state = parseString parseListWordIntegral mempty $ section Map.! "state" + +shake128AbsorbCheck :: Shake128AbsorbValidationParams -> String -> TestTree +shake128AbsorbCheck params variant = testCase ("shake128Absorb (" ++ variant ++ ")") + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = absorbStateVector params + calculatedResult = shake128Absorb $ absorbSeed params + + +data Shake128SqueezeValidationParams = Shake128SqueezeValidationParams { squeezeSeed :: BS.ByteString + , squeezeOutput :: BS.ByteString + , squeezeState :: VU.Vector Word64 + } deriving Show + +squeezeFromConfig :: Assignments -> Shake128SqueezeValidationParams +squeezeFromConfig section = Shake128SqueezeValidationParams { squeezeSeed = seedVector, squeezeOutput = outputVector, squeezeState = stateVector } + where + seedVector = BS.pack $ toIntegralList $ section Map.! "seed" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section Map.! "output" + outputVector = BS.pack output + Text.Trifecta.Success state = parseString parseListWordIntegral mempty $ section Map.! "state" + stateVector = VU.fromList state + +shake128SqueezeBlocksCheck :: Shake128SqueezeValidationParams -> Int -> String -> TestTree +shake128SqueezeBlocksCheck params count variant = testCase ("shake128SqueezeBlocks (" ++ variant ++ ")") + $ assertEqual "it is" (validatedOutput, validatedOutputState) (output, outputState) + where + validatedOutput = squeezeOutput params + validatedOutputState = squeezeState params + startingState = shake128Absorb $ squeezeSeed params + (output, outputState) = shake128SqueezeBlocks startingState count + + +data Shake256ValidationParams = Shake256ValidationParams { shake256Input :: BS.ByteString + , shake256Output :: BS.ByteString + } deriving Show + +shake256FromConfig :: Assignments -> Shake256ValidationParams +shake256FromConfig section = Shake256ValidationParams { shake256Input = inputVector, shake256Output = outputVector } + where + inputVector = BS.pack $ toIntegralList $ section Map.! "seed" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section Map.! "output" + outputVector = BS.pack output + +shake256Check :: Shake256ValidationParams -> String -> TestTree +shake256Check params variant = testCase ("shake256 (" ++ variant ++ ")") + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = shake256Output params + inputVector = shake256Input params + calculatedResult = shake256 inputVector $ BS.length validatedResult + + +data KeccakF1600VectorsValidationParams = KeccakF1600VectorsValidationParams { keccakVectorsInput :: BS.ByteString + , keccakVectorsRate :: Int + , keccakVectorsOutput :: Map.Map Int (VU.Vector Word64) + , keccakVectorsUnifiedOutput :: VU.Vector Word64 + } deriving Show + +keccakVectorsFromConfig :: Assignments -> KeccakF1600VectorsValidationParams +keccakVectorsFromConfig section = KeccakF1600VectorsValidationParams { keccakVectorsInput = inputBS + , keccakVectorsRate = rate + , keccakVectorsOutput = outputMap + , keccakVectorsUnifiedOutput = unifiedVector + } + where + rate = read $ section Map.! "r" + inputBS = hexStringToByteString $ section Map.! "m" + Text.Trifecta.Success unified = parseString parseListWordIntegral mempty $ section Map.! "unified" + unifiedVector = VU.fromList unified + Text.Trifecta.Success output = parseString parseListIntegralMap mempty $ section Map.! "vectors" + outputMap = Map.fromList $ fmap go output + where + go (key, value) = (key, VU.fromList value) + +keccakVectorsCheck :: KeccakF1600VectorsValidationParams -> TestTree +keccakVectorsCheck params = testCase "keccakf1600 vectors check" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = keccakVectorsOutput params + rate = keccakVectorsRate params + input = keccakVectorsInput params + calculatedResult = inputLoadVectors rate input + + +tests :: IO TestTree +tests = do + config <- configFile + + let + statePermuteParams :: StatePermuteValidationParams + statePermuteParams = keccakFromConfig $ sectionNamed config "keccakf1600_statepermute" + + absorbParams :: Shake128AbsorbValidationParams + absorbParams = absorbFromConfig $ sectionNamed config "shake128_absorb" + + absorbParams2 :: Shake128AbsorbValidationParams + absorbParams2 = absorbFromConfig $ sectionNamed config "shake128_absorb_2" + + squeezeParams :: Shake128SqueezeValidationParams + squeezeParams = squeezeFromConfig $ sectionNamed config "shake128_squeezeblocks" + + squeezeParams2 :: Shake128SqueezeValidationParams + squeezeParams2 = squeezeFromConfig $ sectionNamed config "shake128_squeezeblocks_2" + + shake256Params :: Shake256ValidationParams + shake256Params = shake256FromConfig $ sectionNamed config "shake256" + + shake256Params2 :: Shake256ValidationParams + shake256Params2 = shake256FromConfig $ sectionNamed config "shake256_2" + + keccakVectorsParams :: KeccakF1600VectorsValidationParams + keccakVectorsParams = keccakVectorsFromConfig $ sectionNamed config "keccak_absorb.loop" + + + return $ testGroup "FIPS202 Tests" [ keccakPermuteCheck statePermuteParams + , keccakVectorsCheck keccakVectorsParams + , shake128AbsorbCheck absorbParams "#1" + , shake128AbsorbCheck absorbParams2 "#2" + , shake128SqueezeBlocksCheck squeezeParams 1 "#1" + , shake128SqueezeBlocksCheck squeezeParams2 2 "#2" + , shake256Check shake256Params "#1" + , shake256Check shake256Params2 "#2" + ] diff --git a/test/Crypto/NewHope/Test/NTT.hs b/test/Crypto/NewHope/Test/NTT.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/NTT.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.NTT + Description : Testing code for NTT + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.NTT where + +import Data.Map +import qualified Data.Vector.Unboxed as VU +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC hiding (output) +import Text.Trifecta + +import ConfigFile +import Crypto.NewHope.NTT + + +-- all the validation data for these tests +configFile512 :: IO Config +configFile512 = fromFile "NTT_512.cfg" + +configFile1024 :: IO Config +configFile1024 = fromFile "NTT_1024.cfg" + + +-- generate (arbitrary :: Gen Word16Vector512) + +newtype WrappedVUUnbox a = WrappedVUUnbox (VU.Vector a) deriving Show + +instance (Arbitrary a, VU.Unbox a) => Arbitrary (WrappedVUUnbox a) where + arbitrary = fmap (WrappedVUUnbox . VU.fromList) arbitrary + + +newtype Word16Vector512 = Word16Vector512 (VU.Vector Word16) deriving (Eq, Show) +newtype Word16Vector1024 = Word16Vector1024 (VU.Vector Word16) deriving (Eq, Show) + +instance Arbitrary Word16Vector512 where + arbitrary = sized $ \_n -> do + let notN = 512 :: Int + a <- sequence [ suchThat arbitrary (< 512) | _ <- [1..notN]] + return $ Word16Vector512 (VU.fromList a) + +instance Arbitrary Word16Vector1024 where + arbitrary = sized $ \_n -> do + let notN = 1024 :: Int + a <- sequence [ suchThat arbitrary (< 1024) | _ <- [1..notN]] + return $ Word16Vector1024 (VU.fromList a) + + +propRev512 :: Word16Vector512 -> Bool +propRev512 v = v0 == v2 where + Word16Vector512 v0 = v + v1 = bitrev v0 + v2 = bitrev v1 + +propRev1024 :: Word16Vector1024 -> Bool +propRev1024 v = v0 == v2 where + Word16Vector1024 v0 = v + v1 = bitrev v0 + v2 = bitrev v1 + + +data BitReverseValidationParams = BitReverseValidationParams { getBTKeySize :: Int + , getBTInput :: VU.Vector Word16 + , getBTOutput :: VU.Vector Word16 + } deriving Show +btFromConfig :: Config -> BitReverseValidationParams +btFromConfig config = BitReverseValidationParams { getBTKeySize = bits + , getBTInput = inputVector + , getBTOutput = outputVector + } + where + section = config `sectionNamed` "bitrev" + bits = read $ section ! "n" :: Int + Text.Trifecta.Success input = parseString parseListWordIntegral mempty $ section ! "input" + inputVector = VU.fromList input + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputVector = VU.fromList output + + +isBitReverseAccurate :: BitReverseValidationParams -> Bool +isBitReverseAccurate config = expectedOutput == liveResult + where + expectedOutput = getBTOutput config + input = getBTInput config + liveResult = bitrev input + + +bitreverseCheck :: BitReverseValidationParams -> TestTree +bitreverseCheck params = testCase ("bitreverse (N=" ++ show n ++ ")") + (assertEqual "it is" True $ isBitReverseAccurate params) + where + n = getBTKeySize params + + +data NTTValidationParams = NTTValidationParams { getKeySize :: Int + , getInput :: VU.Vector Word16 + , getΩ :: VU.Vector Word16 + , getOutput :: VU.Vector Word16 + } deriving Show + + +nttFromConfig :: Config -> NTTValidationParams +nttFromConfig config = NTTValidationParams { getKeySize = bits + , getInput = inputVector + , getΩ = ωVector + , getOutput = outputVector + } + where + section = config `sectionNamed` "ntt" + bits = read $ findWithDefault "0" "n" section :: Int + Text.Trifecta.Success input = parseString parseListWordIntegral mempty $ section ! "input" + inputVector = VU.fromList input + Text.Trifecta.Success ω = parseString parseListWordIntegral mempty $ section ! "omega" + ωVector = VU.fromList ω + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputVector = VU.fromList output + + +isNTTAccurate :: NTTValidationParams -> Bool +isNTTAccurate config = validResult == liveResult + where + validResult = getOutput config + inputVector = getInput config + ωVector = getΩ config + liveResult = ntt inputVector ωVector + +nttCheck :: NTTValidationParams -> TestTree +nttCheck params = testCase ("ntt (N=" ++ show n ++ ")") + (assertEqual "it is" True $ isNTTAccurate params) + where + n = getKeySize params + + +-- the table entries should be symmetrical +checkTableEntry :: VU.Vector Word16 -> Integer -> Bool +checkTableEntry table n = let + value0 = table VU.! fromIntegral n + value1 = table VU.! fromIntegral value0 + result = value0 == value1 || value1 == fromIntegral n + in result + + +-- check the full table. this should really be sufficient instead of the spot check that the other test provides, iirc +validateBitrevTable :: Int -> Bool +validateBitrevTable bits = and $ checkTableEntry (bitrevTable bits) <$> [0..511] + +bitrevTable512Ok :: TestTree +bitrevTable512Ok = testCase "bitreverse table (N=512) is legit" + (assertEqual "it is" True $ validateBitrevTable 512) + +bitrevTable1024Ok :: TestTree +bitrevTable1024Ok = testCase "bitreverse table (N=1024) is legit" + (assertEqual "it is" True $ validateBitrevTable 1024) + + +tests :: IO TestTree +tests = do + config512 <- configFile512 + config1024 <- configFile1024 + + let btParams512 :: BitReverseValidationParams + btParams512 = btFromConfig config512 + + nttParams512 :: NTTValidationParams + nttParams512 = nttFromConfig config512 + + let btParams1024 :: BitReverseValidationParams + btParams1024 = btFromConfig config1024 + + nttParams1024 :: NTTValidationParams + nttParams1024 = nttFromConfig config1024 + + return $ testGroup "NTT Tests" [ bitreverseCheck btParams512 + , bitreverseCheck btParams1024 + , bitrevTable512Ok + , bitrevTable1024Ok + , nttCheck nttParams512 + , nttCheck nttParams1024 + , QC.testProperty "round trip bitreversal (N=512)" propRev512 + , QC.testProperty "round trip bitreversal (N=1024)" propRev1024 + ] diff --git a/test/Crypto/NewHope/Test/Poly.hs b/test/Crypto/NewHope/Test/Poly.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/Poly.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.Poly + Description : Testing code for Poly + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.Poly where + + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Map +import qualified Data.Vector.Unboxed as VU +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC hiding (output) +import Text.Trifecta + + +import ConfigFile +import qualified Crypto.NewHope.Internals as Internals +import Crypto.NewHope.Poly (Poly (..)) +import qualified Crypto.NewHope.Poly as Poly +import StringUtils + + +-- all the validation data for these tests +configFile :: IO Config +configFile = fromFile "Poly.cfg" + + +data MiscValidationParams = MiscValidationParams { coeffFreezePairs :: [(Word16, Word16)] + , flipabsPairs :: [(Word16, Word16)] + } deriving Show + +miscFromConfig :: Assignments -> MiscValidationParams +miscFromConfig section = MiscValidationParams { coeffFreezePairs = coeffFreezePairs', flipabsPairs = flipabsPairs' } + where + Text.Trifecta.Success coeffFreezePairs' = parseString parseListIntegralPairs mempty $ section ! "coeff_freeze" + Text.Trifecta.Success flipabsPairs' = parseString parseListIntegralPairs mempty $ section ! "flipabs" + +coeffFreezeCheck :: MiscValidationParams -> TestTree +coeffFreezeCheck params = testCase "coeff_freeze" + $ assertBool "broken" allIsWell + where + pairs = coeffFreezePairs params + allIsWell = go pairs + where + go [] = True + go ((a, a') : rest) = (Poly.coeffFreeze a == a') || go rest + +flipabsCheck :: MiscValidationParams -> TestTree +flipabsCheck params = testCase "flipabs" + $ assertBool "broken" allIsWell + where + pairs = flipabsPairs params + allIsWell = go pairs + where + go [] = True + go ((a, a') : rest) = (Poly.flipabs a == a') || go rest + + +newtype WrapPoly = WrapPoly Poly deriving Show + +instance Arbitrary WrapPoly where + arbitrary = do + a <- frequency [ (1, sequence [ arbitrary | _ <- [1 .. 512 :: Int]]) + , (1, sequence [ arbitrary | _ <- [1 .. 1024 :: Int]])] + return $ WrapPoly $ Poly (VU.fromList a) + + +newtype WrapPoly512 = WrapPoly512 Poly deriving Show + +instance Arbitrary WrapPoly512 where + arbitrary = do + a <- sequence [ arbitrary | _ <- [1 .. 512 :: Int]] + return $ WrapPoly512 $ Poly (VU.fromList a) + +newtype WrapPoly1024 = WrapPoly1024 Poly deriving Show + +instance Arbitrary WrapPoly1024 where + arbitrary = do + a <- sequence [ arbitrary | _ <- [1 .. 1024 :: Int]] + return $ WrapPoly1024 $ Poly (VU.fromList a) + + +data ToBytesValidationParams = ToBytesValidationParams { toBytesInput :: Poly + , toBytesOutput :: BS.ByteString + } deriving Show + +toBytesFromConfig :: Assignments -> ToBytesValidationParams +toBytesFromConfig section = ToBytesValidationParams { toBytesInput = inputPoly + , toBytesOutput = outputBS + } + where + Text.Trifecta.Success input = parseString parseListWordIntegral mempty $ section ! "input" + inputPoly = Poly $ VU.fromList input + outputBS = hexStringToByteString $ section ! "output" + + +toBytesCheck :: ToBytesValidationParams -> TestTree +toBytesCheck params = testCase "poly_tobytes" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = toBytesOutput params + calculatedResult = Poly.toByteString $ toBytesInput params + + +data FromBytesValidationParams = FromBytesValidationParams { fromBytesInput :: BS.ByteString + , fromBytesOutput :: Poly + } deriving Show + +fromBytesFromConfig :: Assignments -> FromBytesValidationParams +fromBytesFromConfig section = FromBytesValidationParams { fromBytesInput = inputBS + , fromBytesOutput = outputVector + } + where + inputBS = hexStringToByteString $ section ! "input" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputVector = Poly $ VU.fromList output + + +fromBytesCheck :: FromBytesValidationParams -> TestTree +fromBytesCheck params = testCase "fromByteString" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = fromBytesOutput params + calculatedResult = Poly.fromByteString $ fromBytesInput params + + +-- we need an entire post-routine roundtrip because there is some sort of convergence happening +propPolynomialEncodeRoundtrip :: WrapPoly -> Bool +propPolynomialEncodeRoundtrip (WrapPoly poly) = let + asBytes = Poly.toByteString poly + asPoly = Poly.fromByteString asBytes + asBytes' = Poly.toByteString asPoly + in asBytes == asBytes' + + +data CompressValidationParams = CompressValidationParams { compressInput :: Poly + , compressOutput :: BS.ByteString + } deriving Show + +compressFromConfig :: Assignments -> CompressValidationParams +compressFromConfig section = CompressValidationParams { compressInput = inputPoly + , compressOutput = outputBS + } + where + Text.Trifecta.Success input = parseString parseListWordIntegral mempty $ section ! "input" + inputPoly = Poly $ VU.fromList input + outputBS = hexStringToByteString $ section ! "output" + +compressCheck :: CompressValidationParams -> TestTree +compressCheck params = testCase "poly_compress" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = compressOutput params + calculatedResult = Poly.compress $ compressInput params + + +data DecompressValidationParams = DecompressValidationParams { decompressInput :: BS.ByteString + , decompressOutput :: Poly + } deriving Show + +decompressFromConfig :: Assignments -> DecompressValidationParams +decompressFromConfig section = DecompressValidationParams { decompressInput = inputBS + , decompressOutput = outputPoly + } + where + inputBS = hexStringToByteString $ section ! "input" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputPoly = Poly $ VU.fromList output + + +decompressCheck :: DecompressValidationParams -> TestTree +decompressCheck params = testCase "poly_decompress" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = decompressOutput params + calculatedResult = Poly.decompress $ decompressInput params + + +-- *should* this work? +propCompressionRoundtrip :: Poly -> Bool +propCompressionRoundtrip poly = let + compressed = Poly.compress poly + decompressed = Poly.decompress compressed + recompressed = Poly.compress decompressed + redecompressed = Poly.decompress recompressed + in redecompressed == decompressed + + +data FromMsgValidationParams = FromMsgValidationParams { fromMsgInput :: BS.ByteString + , fromMsgOutput :: Poly + } deriving Show + +fromMsgFromConfig :: Assignments -> FromMsgValidationParams +fromMsgFromConfig section = FromMsgValidationParams { fromMsgInput = inputVector + , fromMsgOutput = outputPoly + } + where + inputVector = BSC.pack $ section ! "input" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputPoly = Poly $ VU.fromList output + + +fromMsgCheck :: FromMsgValidationParams -> TestTree +fromMsgCheck params = testCase "poly_frommsg" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = fromMsgOutput params + n = Poly.getN validatedResult + calculatedResult = Poly.fromMsg n $ fromMsgInput params + +data ToMsgValidationParams = ToMsgValidationParams { toMsgInput :: Poly + , toMsgOutput :: BS.ByteString + } deriving Show + +toMsgFromConfig :: Assignments -> ToMsgValidationParams +toMsgFromConfig section = ToMsgValidationParams { toMsgInput = inputPoly + , toMsgOutput = outputBS + } + where + Text.Trifecta.Success input = parseString parseListWordIntegral mempty $ section ! "input" + inputPoly = Poly $ VU.fromList input + outputBS = hexStringToByteString $ section ! "output" + + +toMsgCheck :: ToMsgValidationParams -> TestTree +toMsgCheck params = testCase "poly_tomsg" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = toMsgOutput params + calculatedResult = Poly.toMsg $ toMsgInput params + +----- + +data UniformValidationParams = UniformValidationParams { uniformSeed :: Internals.Seed + , uniformOutput :: Poly + } + +uniformFromConfig :: Assignments -> UniformValidationParams +uniformFromConfig section = UniformValidationParams { uniformSeed = seed + , uniformOutput = outputPoly + } + where + seed = Internals.makeSeed $ hexStringToByteString $ section ! "seed" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputPoly = Poly $ VU.fromList output + + +uniformCheck :: UniformValidationParams -> TestTree +uniformCheck params = testCase "poly_uniform" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = uniformOutput params + n = Poly.getN validatedResult + calculatedResult = Poly.uniform n $ uniformSeed params + +----- + +data SampleValidationParams = SampleValidationParams { sampleSeed :: Internals.Seed + , sampleNonce :: Word8 + , sampleOutput :: Poly + } + +sampleFromConfig :: Assignments -> SampleValidationParams +sampleFromConfig section = SampleValidationParams { sampleSeed = seed + , sampleNonce = nonce + , sampleOutput = outputPoly + } + where + seed = Internals.makeSeed $ hexStringToByteString $ section ! "seed" + nonce = read $ section ! "nonce" + Text.Trifecta.Success output = parseString parseListWordIntegral mempty $ section ! "output" + outputPoly = Poly $ VU.fromList output + + +sampleCheck :: SampleValidationParams -> TestTree +sampleCheck params = testCase "poly_sample" + $ assertEqual "it is" validatedResult calculatedResult + where + validatedResult = sampleOutput params + n = Poly.getN validatedResult + calculatedResult = Poly.sample n (sampleSeed params) (sampleNonce params) + + +propAddIsCommutative512 :: WrapPoly512 -> WrapPoly512 -> Bool +propAddIsCommutative512 (WrapPoly512 a) (WrapPoly512 b) = ab == ba + where + ab = Poly.add a b + ba = Poly.add b a + +propAddIsCommutative1024 :: WrapPoly1024 -> WrapPoly1024 -> Bool +propAddIsCommutative1024 (WrapPoly1024 a) (WrapPoly1024 b) = ab == ba + where + ab = Poly.add a b + ba = Poly.add b a + + +{- +-- this is not true, but why not? +propAddSub1024 :: WrapPoly1024 -> WrapPoly1024 -> WrapPoly1024 -> Bool +propAddSub1024 (WrapPoly1024 a) (WrapPoly1024 b) (WrapPoly1024 c) = aMinusBMinusC == aMinusQuantityBPlusC + where + aMinusBMinusC = Poly.sub (Poly.sub a b) c + aMinusQuantityBPlusC = Poly.sub a (Poly.add b c) +-} + +tests :: IO TestTree +tests = do + config <- configFile + + let sampleParams :: SampleValidationParams + sampleParams = sampleFromConfig $ config `sectionNamed` "poly.sample" + + miscParams :: MiscValidationParams + miscParams = miscFromConfig $ config `sectionNamed` "poly.misc" + + toBytesParams :: ToBytesValidationParams + toBytesParams = toBytesFromConfig $ config `sectionNamed` "poly.tobytes" + + fromBytesParams :: FromBytesValidationParams + fromBytesParams = fromBytesFromConfig $ config `sectionNamed` "poly.frombytes" + + toMsgParams :: ToMsgValidationParams + toMsgParams = toMsgFromConfig $ config `sectionNamed` "poly.tomsg" + + fromMsgParams :: FromMsgValidationParams + fromMsgParams = fromMsgFromConfig $ config `sectionNamed` "poly.frommsg" + + compressParams :: CompressValidationParams + compressParams = compressFromConfig $ config `sectionNamed` "poly.compress" + + decompressParams :: DecompressValidationParams + decompressParams = decompressFromConfig $ config `sectionNamed` "poly.decompress" + + uniformParams :: UniformValidationParams + uniformParams = uniformFromConfig $ config `sectionNamed` "poly.uniform" + + + return $ testGroup "Poly Tests" [ sampleCheck sampleParams + , coeffFreezeCheck miscParams + , flipabsCheck miscParams + , toBytesCheck toBytesParams + , fromBytesCheck fromBytesParams + , compressCheck compressParams + , decompressCheck decompressParams + , fromMsgCheck fromMsgParams + , toMsgCheck toMsgParams + , uniformCheck uniformParams + , QC.testProperty "round trip poly encode/decode" propPolynomialEncodeRoundtrip + , QC.testProperty "add (N=512) is commutative" propAddIsCommutative512 + , QC.testProperty "add (N=1024) is commutative" propAddIsCommutative1024 + -- , QC.testProperty "round trip poly de/compress" propCompressionRoundtrip + ] diff --git a/test/Crypto/NewHope/Test/RNG.hs b/test/Crypto/NewHope/Test/RNG.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/RNG.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.RNG + Description : Testing code for RNG + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.RNG where + +import Codec.Crypto.AES +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Map +import Test.QuickCheck (Arbitrary, arbitrary) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +import ConfigFile +import Crypto.NewHope.Internal.RNG +import StringUtils + + +configFile :: IO Config +configFile = fromFile "RNG.cfg" + + +newtype WrapKey = WrapKey Key + +instance Show WrapKey + where + show (WrapKey (Key bs)) = "Key: " ++ byteStringToHexString bs + + +newtype WrapV = WrapV V deriving Eq + +instance Show WrapV + where + show (WrapV (V bs)) = "V: " ++ byteStringToHexString bs + + +newtype WrapContext = WrapContext Context + +instance Show WrapContext where + show (WrapContext (Context key v reseedCounter)) = "Context {" + ++ "ctxKey = " ++ show (WrapKey key) ++ ", " + ++ "ctxV = " ++ show (WrapV v) ++ ", " + ++ "ctxReseedCounter = " ++ show reseedCounter ++ "}" + + + +instance Arbitrary WrapKey where + arbitrary = do + key <- sequence [ arbitrary | _ <- [1 .. keyBytes]] + return $ WrapKey $ createKey $ BSC.pack key + +instance Arbitrary WrapV where + arbitrary = do + v <- sequence [ arbitrary | _ <- [1 .. vBytes]] + return $ WrapV $ createV $ BSC.pack v + +instance Arbitrary WrapContext + where + arbitrary = do + wrappedKey <- arbitrary + wrappedV <- arbitrary + reseedCounter <- arbitrary + + let WrapKey key = wrappedKey + let WrapV v = wrappedV + + return $ WrapContext Context { ctxKey = key + , ctxV = v + , ctxReseedCounter = abs reseedCounter + } + + + + + +data RNGValidationParams = RNGValidationParams { rngEntropy :: BS.ByteString + , rngKey :: BS.ByteString + , rngV :: BS.ByteString + , rngBlock0 :: BS.ByteString + , rngBlock1 :: BS.ByteString + , rngBlock2 :: BS.ByteString + } deriving Show + +rngFromConfig :: Assignments -> RNGValidationParams +rngFromConfig section = RNGValidationParams { rngEntropy = hexStringToByteString $ section ! "entropy_input" + , rngKey = hexStringToByteString $ section ! "key" + , rngV = hexStringToByteString $ section ! "v" + , rngBlock0 = hexStringToByteString $ section ! "block0" + , rngBlock1 = hexStringToByteString $ section ! "block1" + , rngBlock2 = hexStringToByteString $ section ! "block2" + } + + +keyAndVCheck :: RNGValidationParams -> TestTree +keyAndVCheck params = testCase "rng key and v generation" + $ assertBool "broken" allIsWell + where + entropy = makeRandomSeed $ rngEntropy params + ctx = randomBytesInit entropy Nothing 256 -- note that the 256 is ignored! + + keyVerified = rngKey params + Key keyActual = ctxKey ctx + keyIsOK = keyVerified == keyActual + + vVerified = rngV params + V vActual = ctxV ctx + vIsOK = vVerified == vActual + + allIsWell = keyIsOK && vIsOK + + +blocksCheck :: RNGValidationParams -> TestTree +blocksCheck params = testCase "rng block generation" + $ assertBool "broken" allIsWell + where + entropy = makeRandomSeed $ rngEntropy params + ctx = randomBytesInit entropy Nothing 256 -- note that the 256 is ignored! + + block0Verified = rngBlock0 params + (block0, ctx0) = randomBytes ctx $ BS.length block0Verified + block0IsOK = block0Verified == block0 + + block1Verified = rngBlock1 params + (block1, ctx1) = randomBytes ctx0 $ BS.length block1Verified + block1IsOK = block1Verified == block1 + + block2Verified = rngBlock2 params + (block2, _ctx2) = randomBytes ctx1 $ BS.length block2Verified + block2IsOK = block2Verified == block2 + + allIsWell = block0IsOK && block1IsOK && block2IsOK + +blocksCheck' :: RNGValidationParams -> TestTree +blocksCheck' params = testCaseSteps "rng block generation" $ \ step -> do + step "Making seed" + let entropy = makeRandomSeed $ rngEntropy params + let ctx = randomBytesInit entropy Nothing 256 -- note that the 256 is ignored! + + step "Generating block 0" + let block0Verified = rngBlock0 params + let (block0, ctx0) = randomBytes ctx $ BS.length block0Verified + block0Verified == block0 @? "Block 0 not generated properly" + + step "Generating block 1" + let block1Verified = rngBlock1 params + let (block1, ctx1) = randomBytes ctx0 $ BS.length block1Verified + block1Verified == block1 @? "Block 1 not generated properly" + + step "Generating block 2" + let block2Verified = rngBlock2 params + let (block2, _ctx2) = randomBytes ctx1 $ BS.length block2Verified + block2Verified == block2 @? "Block 2 not generated properly" + + + + +testIncrementV :: TestTree +testIncrementV = testGroup "Incrementing a V" [ incrementCheckBasic + , incrementCheckTwoWraps + , incrementCheckFifteenWraps + , incrementCheckWrapAround + ] + +incrementCheckBasic :: TestTree +incrementCheckBasic = testCase "Incrementing a v - final byte" + (assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where + first = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + firstIncremented = incrementV first + second = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,16] + +incrementCheckTwoWraps :: TestTree +incrementCheckTwoWraps = testCase "Incrementing a v - two wraps" + (assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where + first = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,13,255,255] + firstIncremented = incrementV first + second = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,14,0,0] + +incrementCheckFifteenWraps :: TestTree +incrementCheckFifteenWraps = testCase "Incrementing a v - 15 wraps" + (assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where + first = createV $ BS.pack [254,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255] + firstIncremented = incrementV first + second = createV $ BS.pack [255,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] + +incrementCheckWrapAround :: TestTree +incrementCheckWrapAround = testCase "Incrementing a v - wraparound" + (assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where + first = createV $ BS.pack [255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255] + firstIncremented = incrementV first + second = createV $ BS.pack [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] + + + + +-- AES tests are here because RNG is where we use AES. + +newtype TestPlaintext = TestPlaintext { getText :: BS.ByteString } deriving (Eq, Show) + +instance Arbitrary TestPlaintext where + arbitrary = sized $ \ n -> do + a <- sequence [ arbitrary | _ <- [1 .. n]] + return $ TestPlaintext (BSC.pack a) + + +newtype AES256IV = AES256IV BS.ByteString deriving Show + +aes256IVLength :: Int +aes256IVLength = 16 + +instance Arbitrary AES256IV + where + arbitrary = do + a <- sequence [ arbitrary | _ <- [1 .. aes256IVLength]] + return $ AES256IV $ BSC.pack a + + +-- using two different IVs to the crypt' function because ECB doesn't use the IV. +propCryptDecrypt :: WrapKey -> AES256IV -> AES256IV -> TestPlaintext -> Bool +propCryptDecrypt key iv iv2 plaintext = let + WrapKey (Key key') = key + AES256IV iv' = iv + AES256IV iv2' = iv2 + TestPlaintext plaintext' = plaintext + plaintext'' = pad ' ' 16 plaintext' + encrypted = crypt' ECB key' iv' Encrypt plaintext'' + decrypted = crypt' ECB key' iv2' Decrypt encrypted + decrypted' = BSC.take (BS.length plaintext') decrypted + in plaintext' == decrypted' + + +------------------- + +-- for manual investigation, not part of test suite +encryptionRoundtrip :: String -> IO BS.ByteString +encryptionRoundtrip plaintext = do + WrapV (V iv') <- generate (arbitrary :: Gen WrapV) + WrapKey (Key key') <- generate (arbitrary :: Gen WrapKey) + let plaintext' = pad ' ' 16 (BSC.pack plaintext) + let encrypted = crypt' ECB key' iv' Encrypt plaintext' + let decrypted = crypt' ECB key' iv' Decrypt encrypted + let decrypted' = BSC.take (Prelude.length plaintext) decrypted + return decrypted' + + + + +tests :: IO TestTree +tests = do + config <- configFile + + let rngParams :: RNGValidationParams + rngParams = rngFromConfig $ config `sectionNamed` "rng" + + return $ testGroup "RNG Tests" [ QC.testProperty "round trip AES encryption" propCryptDecrypt + , QC.testProperty "round trip AES encryption (plaintext size 100)" (mapSize (const 100) propCryptDecrypt) + , QC.testProperty "round trip AES encryption (plaintext size 1025)" (mapSize (const 1025) propCryptDecrypt) + , testIncrementV + , blocksCheck' rngParams] diff --git a/test/Crypto/NewHope/Test/Reduce.hs b/test/Crypto/NewHope/Test/Reduce.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/Reduce.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.Reduce + Description : Testing code for Reduce + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.Reduce where + +import Data.Map +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit +import Text.Trifecta + +import ConfigFile +import Crypto.NewHope.Reduce (montgomeryReduce) + + +type Values = (Word32, Word16) + +newtype MontgomeryReduceValidationParams = MontgomeryReduceValidationParams { values :: [Values] + } deriving Show + + +mrFromConfig :: Config -> MontgomeryReduceValidationParams +mrFromConfig cfg = MontgomeryReduceValidationParams { values = vals } + where + section = cfg `sectionNamed` "montgomery_reduce" + --Success vals = parseString parseValues mempty $ section ! "values" + Success vals = parseString parseListIntegralPairs mempty $ section ! "values" + + +isMontgomeryReduceAccurate :: MontgomeryReduceValidationParams -> Bool +isMontgomeryReduceAccurate MontgomeryReduceValidationParams { values = v } = go v + where + go [] = True + go ((input, output) : rest) = montgomeryReduce input == output && go rest + + +configFile :: IO Config +configFile = fromFile "Reduce.cfg" + +montgomeryReduceCheck :: MontgomeryReduceValidationParams -> TestTree +montgomeryReduceCheck params = testCase "montgomery reduce" + (assertEqual "it is" True $ isMontgomeryReduceAccurate params) + + +tests :: IO TestTree +tests = do + config <- configFile + + let mrParams :: MontgomeryReduceValidationParams + mrParams = mrFromConfig config + + return $ testGroup "Reduce Tests" [montgomeryReduceCheck mrParams] diff --git a/test/Crypto/NewHope/Test/SeedExpander.hs b/test/Crypto/NewHope/Test/SeedExpander.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/SeedExpander.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.SeedExpander + Description : Testing code for SeedExpander + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.SeedExpander where + + +import qualified Data.ByteString as BS +import Data.Map +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit + + +import ConfigFile +import qualified Crypto.NewHope.Internal.RNG as RNG +import qualified Crypto.NewHope.Internal.SeedExpander as SE +import Crypto.NewHope.Internals (Seed, makeSeed) +import Crypto.NewHope.Test.RNG (WrapKey (..), WrapV (..)) +import StringUtils + + +configFile :: IO Config +configFile = fromFile "SeedExpander.cfg" + +data SEContextParams = SEContextParams { ctxIndex :: Int + , ctxBuffer :: BS.ByteString + , ctxBufferPos :: Word64 + , ctxLengthRemaining :: Word64 + , ctxKey :: RNG.Key + , ctxCounter :: RNG.V + } + + +makeBaseContext :: SEContextParams -> SE.Context +makeBaseContext seCtx = SE.Context { SE.ctxBuffer = ctxBuffer seCtx + , SE.ctxBufferPos = ctxBufferPos seCtx + , SE.ctxLengthRemaining = ctxLengthRemaining seCtx + , SE.ctxKey = ctxKey seCtx + , SE.ctxCounter = ctxCounter seCtx + } + +instance Show SEContextParams + where + show ctx = "SECP { n = " ++ show (ctxIndex ctx) + ++ ", buffer = " ++ byteStringToHexString (ctxBuffer ctx) + ++ ", bufferPos = " ++ show (ctxBufferPos ctx) + ++ ", lengthRemaining = " ++ show (ctxLengthRemaining ctx) + ++ ", key = " ++ show (WrapKey $ ctxKey ctx) + ++ ", payload = " ++ show (WrapV $ ctxCounter ctx) + ++ "}" + + +data SEValidationParams = SEValidationParams { seSeed :: Seed + , seDiversifier :: BS.ByteString + , seCtxs :: [SEContextParams] + , seGenBufs :: [BS.ByteString] + } + + +seFromConfig :: Assignments -> SEValidationParams +seFromConfig section = SEValidationParams { seSeed = seed + , seDiversifier = diversifier + , seCtxs = ctxs + , seGenBufs = genBufs + } + + where + seed = makeSeed $ hexStringToByteString $ section ! "seed" + diversifier = hexStringToByteString $ section ! "diversifier" + ctxs = [getCtx 0, getCtx 1, getCtx 2, getCtx 3, getCtx 4] -- order is important. + genBufs = [getGenBuf 1, getGenBuf 2, getGenBuf 3, getGenBuf 4] -- order is important. + + -- ctx n results in genBuf n+1 and ctx n+1 + getGenBuf :: Int -> BS.ByteString + getGenBuf n = result + where + Just result = hexStringToByteString <$> section !? ("genbuf" ++ show n) + + getCtx n = SEContextParams { ctxIndex = n + , ctxBuffer = buffer + , ctxBufferPos = bufferPos + , ctxLengthRemaining = lengthRemaining + , ctxKey = key + , ctxCounter = counter + } + where + Just buffer = hexStringToByteString <$> section !? ("buffer" ++ show n) + Just bufferPos = read <$> section !? ("buffer_pos" ++ show n) + Just lengthRemaining = read <$> section !? ("length_remaining" ++ show n) + Just key = RNG.createKey . hexStringToByteString <$> section !? ("key" ++ show n) + Just counter = RNG.createV . hexStringToByteString <$> section !? ("ctr" ++ show n) + + +seCheck :: SEValidationParams -> TestTree +seCheck params = testCase "seedexpander" + $ assertBool "broken" allIsWell + where + maxLengthBytes = ctxLengthRemaining $ seCtxs params !! 0 + validGenBufs = seGenBufs params + Right diversifier = SE.createDiversifier (seDiversifier params) -- >>= return + Right maxLen = SE.maxLen maxLengthBytes + Right ctx0 = SE.seedexpanderInit (seSeed params) diversifier maxLen + Right (genBuf1, ctx1) = SE.seedexpander ctx0 $ fromIntegral $ BS.length (validGenBufs !! 0) + Right (genBuf2, ctx2) = SE.seedexpander ctx1 $ fromIntegral $ BS.length (validGenBufs !! 1) + Right (genBuf3, ctx3) = SE.seedexpander ctx2 $ fromIntegral $ BS.length (validGenBufs !! 2) + Right (genBuf4, ctx4) = SE.seedexpander ctx3 $ fromIntegral $ BS.length (validGenBufs !! 3) + genBufs = [genBuf1, genBuf2, genBuf3, genBuf4] + + ctxs = [ctx0, ctx1, ctx2, ctx3, ctx4] + ctxOK :: Int -> SE.Context -> Bool + ctxOK n ctx = ctx == makeBaseContext (seCtxs params !! n) + + allIsWell = and (zipWith ctxOK [0, 1, 2, 3, 4] ctxs) + && and (zipWith (==) genBufs validGenBufs) + + +------------------- + +tests :: IO TestTree +tests = do + config <- configFile + + let seParams :: SEValidationParams + seParams = seFromConfig $ config `sectionNamed` "seedexpander" + + return $ testGroup "SeedExpander Test" [ seCheck seParams + ] diff --git a/test/Crypto/NewHope/Test/Verify.hs b/test/Crypto/NewHope/Test/Verify.hs new file mode 100644 --- /dev/null +++ b/test/Crypto/NewHope/Test/Verify.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Crypto.NewHope.Test.Verify + Description : Test Verify + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Crypto.NewHope.Test.Verify where + + +import Control.Parallel +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import System.CPUTime +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.QuickCheck as QC + + +import Crypto.NewHope.Verify +import Statistics + + +sizeOfWrappedThings :: Int +sizeOfWrappedThings = 100 + +trialCount :: Int +trialCount = 100000 -- this is probably enough. + + +newtype WrappedVUUnbox a = WrappedVUUnbox (VU.Vector a) deriving Show + +instance (Arbitrary a, VU.Unbox a) => Arbitrary (WrappedVUUnbox a) where + arbitrary = fmap (WrappedVUUnbox . VU.fromList) arbitrary + + +newtype Wrapped a = Wrapped a deriving Show + +instance {-# OVERLAPS #-} Show [Wrapped a] + where + show as = "[array of " ++ show (length as) ++ "]" + +deWrapped :: Wrapped a -> a +deWrapped (Wrapped a) = a + +instance (Semigroup a) => Semigroup (Wrapped a) + where + (Wrapped a) <> (Wrapped b) = Wrapped (a <> b) + +instance (Semigroup a, Monoid a) => Monoid (Wrapped a) + where + mempty = Wrapped mempty + mappend (Wrapped a) (Wrapped b) = Wrapped (mappend a b) + +instance Functor Wrapped + where + fmap f (Wrapped a) = Wrapped (f a) + +instance Arbitrary (Wrapped String) + where + arbitrary = Wrapped <$> vectorOf sizeOfWrappedThings genWrappedChar + where + genWrappedChar = elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ " .,;:/|()[]{}!@#$%^&*<>" + + +instance Arbitrary (Wrapped BS.ByteString) + where + arbitrary = (fmap . fmap) BSC.pack arbitrary + +instance (Arbitrary a, VU.Unbox a) => Arbitrary (Wrapped (V.Vector a)) + where + arbitrary = (fmap . fmap) V.fromList v + where + v = Wrapped <$> vectorOf sizeOfWrappedThings arbitrary + +instance Arbitrary (Wrapped (VU.Vector Char)) + where + arbitrary = (fmap . fmap) VU.fromList arbitrary + + +genFixedLengthList :: (Arbitrary a) => Int -> Gen [a] +genFixedLengthList n = sequence [ arbitrary | _ <- [1 .. n]] + + +generateBigBytestringPair :: Gen ([Wrapped BS.ByteString], [Wrapped BS.ByteString]) +generateBigBytestringPair = do + a <- genFixedLengthList trialCount :: Gen [Wrapped BS.ByteString] + b <- genFixedLengthList trialCount :: Gen [Wrapped BS.ByteString] + return (a, b) + +generateBigBytestringPairs :: Gen [(Wrapped BS.ByteString, Wrapped BS.ByteString)] +generateBigBytestringPairs = do + a <- arbitrary :: Gen (Wrapped BS.ByteString) + b <- arbitrary :: Gen (Wrapped BS.ByteString) + rest <- generateBigBytestringPairs + let firstItem = (a, b) + return $ firstItem : rest + + +----------------------- + +-- | Somewhat deep magic: Test a property in IO, which is required +-- here because we check the CPU time. The basic idea is that f1 and +-- f2 (when called on the pairs of items from as and bs) should take +-- as close to the same amount of time as possible, and this test +-- should succeed iff we should be confident that this is true. +runTimingTests :: Monoid a => (a -> a -> b) -> (a -> a -> b) -> [Wrapped a] -> [Wrapped a] -> PropertyM IO () +runTimingTests f1 f2 as bs = do allTimes <- run (traverse getTimeDifference $ zip as' bs') + let (low, high) = confidence 0.95 allTimes + -- TODO: just checking for 0 being included in the confidence interval is stupidly insufficient. + -- we should also check to see that the confidence interval is sufficiently narrow. but how narrow + -- is appropriate? + assert $ (low < 0) && (high > 0) + where + as' = deWrapped <$> as + bs' = deWrapped <$> bs + + -- value returned represents the difference between measurement A and measurement B for a paired observation. + getTimeDifference (a, b) = do + start_1 <- getCPUTime + time_1 <- pseq (f1 a b) getCPUTime + start_2 <- getCPUTime + time_2 <- pseq (f2 a b) getCPUTime + let time_1' = time_1 - start_1 + let time_2' = time_2 - start_2 + return (time_1' - time_2') + + +----------------------- + +propTimingPairBytestringCTC :: Property +propTimingPairBytestringCTC = forAll generateBigBytestringPair evaluator + where + evaluator :: ([Wrapped BS.ByteString], [Wrapped BS.ByteString]) -> Property + evaluator (as, bs) = monadicIO $ runTimingTests chooseA chooseB as bs + + chooseA = constantTimeChoose True + chooseB = constantTimeChoose False + +----------------------- + +propTimingPairBytestringCmov :: Property +propTimingPairBytestringCmov = forAll generateBigBytestringPair evaluator + where + evaluator :: ([Wrapped BS.ByteString], [Wrapped BS.ByteString]) -> Property + evaluator (as, bs) = monadicIO $ runTimingTests chooseA chooseB as bs + + chooseA = cmov True + chooseB = cmov False + +----------------------- + +propTimingPairBytestringVerify :: Property +propTimingPairBytestringVerify = forAll generateBigBytestringPair evaluator + where + evaluator :: ([Wrapped BS.ByteString], [Wrapped BS.ByteString]) -> Property + evaluator (as, bs) = monadicIO $ runTimingTests chooseA chooseB as bs + + chooseA a b = verify a b -- will return False + chooseB a _ = verify a a -- will return True (using the first argument) + +propTimingPairBytestringVerify' :: Property +propTimingPairBytestringVerify' = forAll generateBigBytestringPair evaluator + where + evaluator :: ([Wrapped BS.ByteString], [Wrapped BS.ByteString]) -> Property + evaluator (as, bs) = monadicIO $ runTimingTests chooseA chooseB as bs + + chooseA a b = verify a b -- Will return False + chooseB _ b = verify b b -- Will return True (using the second argument) + +----------------------- + +tests :: TestTree +tests = testGroup "Verify Tests" + [ adjustOptions $ QC.testProperty "verify ByteString comparison is constant time (#1)" propTimingPairBytestringVerify + , adjustOptions $ QC.testProperty "verify ByteString comparison is constant time (#2)" propTimingPairBytestringVerify' + , adjustOptions $ QC.testProperty "constantTimeChoose is constant time" propTimingPairBytestringCTC + , adjustOptions $ QC.testProperty "cmov is constant time" propTimingPairBytestringCmov + ] + where + adjustOptions :: TestTree -> TestTree + adjustOptions = adjustOption setTests + . adjustOption setMaxSize + . adjustOption setVerbose + . adjustOption setShowReplay + where + setTests :: QuickCheckTests -> QuickCheckTests + setTests _opt = QuickCheckTests 1 + + setMaxSize :: QuickCheckMaxSize -> QuickCheckMaxSize + setMaxSize _opt = QuickCheckMaxSize 1 + + setVerbose :: QuickCheckVerbose -> QuickCheckVerbose + setVerbose _opt = QuickCheckVerbose False + + setShowReplay :: QuickCheckShowReplay -> QuickCheckShowReplay + setShowReplay _opt = QuickCheckShowReplay False diff --git a/test/Statistics.hs b/test/Statistics.hs new file mode 100644 --- /dev/null +++ b/test/Statistics.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Statistics + Description : Statistics helpers for testing. + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Statistics where + +import Statistics.Distribution hiding (mean) +import Statistics.Distribution.StudentT + + +-- | Confidence range using the Student T distribution +confidence :: Double -> [Integer] -> (Double, Double) +confidence factor as = (rangeLow, rangeHigh) + where + rangeLow = mean - base + rangeHigh = mean + base + n = length as + df = fromIntegral $ n - 1 + mean = fromIntegral (sum as) / fromIntegral n + σ = stddev as + distribution = studentT df + tQuantile = quantile distribution doubleTailProbability + base = abs $ tQuantile * se + se = σ / sqrt (fromIntegral n) + doubleTailProbability = (1.0 - factor) / 2 + + +-- | Standard deviation +stddev :: [Integer] -> Double +stddev as = sqrt $ realToFrac (sum squaredDiffFromMean / (len - 1)) + where + as' = toRational <$> as + len = fromIntegral $ length as + mean = sum as' / len + diffFromMean = (\a -> a - toRational mean) <$> as' + squaredDiffFromMean = (^ (2::Int)) <$> diffFromMean diff --git a/test/Test/ConfigFile.hs b/test/Test/ConfigFile.hs new file mode 100644 --- /dev/null +++ b/test/Test/ConfigFile.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-| + Module : Test.ConfigFile + Description : Tests our ability to parse our testing configuration files + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Test.ConfigFile where + + +import qualified Data.ByteString as BS (ByteString) +import qualified Data.Map as M +import Prelude +import Test.Tasty +import Test.Tasty.HUnit +import Text.RawString.QQ +import Text.Trifecta hiding (expected) + +import qualified ConfigFile + + +maybeSuccess :: Result a -> Maybe a +maybeSuccess (Success a) = Just a +maybeSuccess _ = Nothing + + +assignmentCheck :: TestTree +assignmentCheck = testCase "Assignment Parsing" $ do + let m = parseByteString ConfigFile.parseAssignment mempty input + parsed = maybeSuccess m + input = "simply=listen" + assertEqual "simple assignment" parsed $ Just ("simply", "listen") + + +headerCheck :: TestTree +headerCheck = testCase "Header Parsing" $ do + let m = parseByteString ConfigFile.parseHeader mempty input + parsed = maybeSuccess m + input = "[important]" + assertEqual "header" parsed $ Just (ConfigFile.Header "important") + + +commentCheck :: TestTree +commentCheck = testCase "Comment Parsing" $ do + let p = ConfigFile.skipComments >> ConfigFile.parseHeader + m = parseByteString p mempty input + parsed = maybeSuccess m + input = "; this is imporant\n[not_important]" + assertEqual "skip comment before header" parsed $ Just (ConfigFile.Header "not_important") + + +sectionCheck :: TestTree +sectionCheck = testCase "Section Parsing" $ do + let m = parseByteString ConfigFile.parseSection mempty input + parsed = maybeSuccess m + input = "; super important\n[cheese_opinions]\ncheddar=fine" + expected = Just (ConfigFile.Section + (ConfigFile.Header "cheese_opinions") + (M.fromList [("cheddar", "fine")])) + assertEqual "skip comment before header" parsed expected + + +fullFile :: BS.ByteString +fullFile = [r| +; do not read this information +; you may find it artless +[animal_info] +crawler=wombat +bird=colibri + +[charming] +quokka=super +|] + + +fileCheck :: TestTree +fileCheck = testCase "File Parsing" $ do + let m = parseByteString ConfigFile.parseIni mempty fullFile + parsed = maybeSuccess m + sectionValues = M.fromList [ ("bird", "colibri") + , ("crawler", "wombat")] + charming = M.fromList [("quokka", "super")] + expected = Just (ConfigFile.Config (M.fromList [ (ConfigFile.Header "animal_info", sectionValues) + , (ConfigFile.Header "charming", charming)])) + assertEqual "can parse multiple sections" parsed expected + + + +tests :: TestTree +tests = testGroup "ConfigFile tests" [ assignmentCheck + , headerCheck + , commentCheck + , sectionCheck + , fileCheck + ] diff --git a/test/Test/KAT.hs b/test/Test/KAT.hs new file mode 100644 --- /dev/null +++ b/test/Test/KAT.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE Trustworthy #-} +{-| + Module : Test.KAT + Description : Test validity of our KAT output + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + + Tests to demonstrate that this implementation creates the same + PQCkemKAT data as the reference C implementation. + +-} + +module Test.KAT where + + +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding +import Filesystem +import Filesystem.Path.CurrentOS hiding (valid) +import Test.Tasty +import Test.Tasty.HUnit + + +import AuxUtil +import qualified Crypto.NewHope.Internals as Internals +import KAT + + +officialKATFilesPath :: String +officialKATFilesPath = "etc/official_kat/" + + +fileContents :: String -> IO Text +fileContents fn = readTextFile $ fromText . Text.pack $ fn + + +cpaKatCheck :: Internals.N -> String -> Text -> TestTree +cpaKatCheck n fileName valid = + testCase ("CPA KAT validation, N=" ++ show (WrapN n)) $ do + fileName @=? builtFileName + validBSLazy @=? generated + where + (builtFileName, built) = KAT.cpaKemTestVectors n recordsToGenerate + validBSLazy = BSL.fromStrict validBS + validBS = encodeUtf8 valid + generated = toLazyByteString built + + +ccaKatCheck :: Internals.N -> String -> Text -> TestTree +ccaKatCheck n fileName valid = + testCase ("CCA KAT validation, N=" ++ show (WrapN n)) $ do + fileName @=? builtFileName + validBSLazy @=? generated + where + (builtFileName, built) = KAT.ccaKemTestVectors n recordsToGenerate + validBSLazy = BSL.fromStrict validBS + validBS = encodeUtf8 valid + generated = toLazyByteString built + + + +tests :: IO TestTree +tests = do + validCpa512 <- fileContents $ officialKATFilesPath ++ "PQCkemKAT_896.rsp" + validCpa1024 <- fileContents $ officialKATFilesPath ++ "PQCkemKAT_1792.rsp" + validCca512 <- fileContents $ officialKATFilesPath ++ "PQCkemKAT_1888.rsp" + validCca1024 <- fileContents $ officialKATFilesPath ++ "PQCkemKAT_3680.rsp" + + return $ testGroup "KAT tests" + [ cpaKatCheck Internals.N512 "PQCkemKAT_896.rsp" validCpa512 + , cpaKatCheck Internals.N1024 "PQCkemKAT_1792.rsp" validCpa1024 + , ccaKatCheck Internals.N512 "PQCkemKAT_1888.rsp" validCca512 + , ccaKatCheck Internals.N1024 "PQCkemKAT_3680.rsp" validCca1024 + ] diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE Safe #-} +{-| + Module : Util + Description : Testing utility + Copyright : © Jeremy Bornstein 2019 + License : Apache 2.0 + Maintainer : jeremy@bornstein.org + Stability : experimental + Portability : portable + +-} + +module Util where + +import Data.Bits +import qualified Data.ByteString as BS +import Data.Set +import Data.Word + +import qualified Crypto.NewHope.Internal.RNG as RNG + +mutateOneBit :: RNG.Context -> BS.ByteString -> (BS.ByteString, RNG.Context) +mutateOneBit ctx input = (output, ctx') + where + (offset, ctx') = RNG.randomInteger ctx (0, fromIntegral $ BS.length input - 1) + (bitNum, _ctx'') = RNG.randomInteger ctx' (0, 7) + shiftedBit = shiftL (0x01 :: Word8) (fromIntegral bitNum) + (part1, part2) = BS.splitAt (fromIntegral offset) input + (part2a, part2b) = BS.splitAt 1 part2 + part2a' = BS.pack [xor (BS.index part2a 0) shiftedBit] + output = BS.concat [part1, part2a', part2b] + + +mutateBits :: RNG.Context -> Int -> BS.ByteString -> (BS.ByteString, RNG.Context) +mutateBits ctx n input = (output, ctx') + where + bitCount = BS.length input * 8 + (bitsToMutate, ctx') = randomSetOfSize ctx bitCount n + output = Prelude.foldr go input bitsToMutate + where + go index bs = BS.concat [part1, part2a', part2b] + where + offset = index `div` 8 + shiftedBit = shiftL (0x01 :: Word8) (index `mod` 8) + (part1, part2) = BS.splitAt (fromIntegral offset) bs + (part2a, part2b) = BS.splitAt 1 part2 + part2a' = BS.pack [xor (BS.index part2a 0) shiftedBit] + + +-- | A nonrepeating set of 大きさ (or n, whichever is smaller) random +-- integers from 0 to n. +randomSetOfSize :: RNG.Context -> Int -> Int -> (Set Int, RNG.Context) +randomSetOfSize ctx n 大きさ = go ctx empty + where + 大きさ' = min n 大きさ + go ctx_ prevResult + | length prevResult == 大きさ' = (prevResult, ctx_) + | otherwise = go ctx_' nextResult + where + (choice, ctx_') = RNG.randomInteger ctx_ (0, fromIntegral n - 1) + nextResult = insert (fromIntegral choice) prevResult