├── .gitignore ├── LICENSE ├── README.md ├── examples ├── adder │ ├── Evaluator.hs │ ├── Example │ │ └── Adder.hs │ ├── Garbler.hs │ ├── adder.cabal │ └── build.sh ├── bit-and │ ├── Evaluator.hs │ ├── Garbler.hs │ ├── bit-and.cabal │ └── build.sh └── classifier │ ├── Evaluator.hs │ ├── Example │ └── Classifier.hs │ ├── Garbler.hs │ ├── build.sh │ └── classifier.cabal ├── garbled-circuits.cabal ├── src └── Crypto │ ├── GarbledCircuits.hs │ └── GarbledCircuits │ ├── Encryption.hs │ ├── Eval.hs │ ├── GarbledGate.hs │ ├── Language.hs │ ├── Network.hs │ ├── ObliviousTransfer.hs │ ├── TruthTable.hs │ ├── Types.hs │ └── Util.hs └── test ├── Main.hs ├── TestGarbledCircuits.hs └── TestObliviousTransfer.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | Setup.hs 5 | *.a 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright 2015 Brent Carmer 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | garbled-circuits 2 | ================ 3 | ![garbled circuit picture](https://web.engr.oregonstate.edu/~rosulekm/scbib.png) 4 | 5 | This library is a Haskell DSL for secure two-party computation with garbled 6 | circuits. You can use it to create secure protocols in the honest but curious 7 | model. That is - parties in the protocols won't find out each other's inputs, as 8 | long as they follow the protocol. 9 | 10 | overview 11 | ======== 12 | 13 | Two parties can make a garbled circuit to find the output of a function without 14 | learning each other's input. The function can be any that can be expressed as a 15 | boolean circuit. Each gate of the circuit encrypts its output by using its input 16 | as keys. Since a party can only know a gate's output if it has the right input, 17 | only the correct output is recoverable. 18 | 19 | The two parties are the `Garbler` and the `Evaluator`, who agree on a circuit to 20 | compute. The `Garbler` creates random values for each wire in the circuit (we 21 | call them wirelabels) and encrypts the output of each gate with its input 22 | wirelabels. The `Garbler` begins the protocol by sending its input wirelabels 23 | and the garbled circuit to the `Evaluator`. Next, the `Evaluator` needs to find 24 | out what its input wirelabels are, but do so without revealing what its input 25 | is. We use [oblivious transfer](https://en.wikipedia.org/wiki/Oblivious_transfer) 26 | for that. The `Evaluator` evaluates the circuit and sends the output wirelabels back to the `Garbler`, who ungarbles them and reveals the output to the `Evaluator`. 27 | 28 | `garbled-circuits` supports the latest circuit-size optimizations, including 29 | [half-gates](http://eprint.iacr.org/2014/756), and uses AES128 with AESNI 30 | support for hashing. It uses [oblivious transfer 31 | extension](https://web.engr.oregonstate.edu/~rosulekm/scbib/index.php?n=Paper.IKNP03) 32 | to minimize the number of expensive oblivious transfers (which are based on 33 | asymmetric crypto). 34 | 35 | usage 36 | ----- 37 | 38 | In this section, we'll show how to construct a simple bitwise 'and' protocol. 39 | We'll be constructing two source files: `Garbler.hs` and `Evaluator.hs` to 40 | be the respecive parties in the protocol. You can find these files in the 41 | `examples/bit-and` directory. 42 | 43 | First we define a circuit using the `Crypto.GarbledCircuits.Language` module. 44 | We use the smart constructors in the way you'd expect any normal monadic code 45 | to work. Note, since this is a two-party protocol, we need to specify where 46 | input comes from. That's what the `Garbler` and `Evaluator` data constructors 47 | are for. 48 | 49 | The following code is common to both `Garbler.hs` and `Evaluator.hs` 50 | 51 | ```haskell 52 | module Main where 53 | 54 | import Prelude hiding (and) 55 | import System.Environment 56 | 57 | import Crypto.GarbledCircuits 58 | import Crypto.GarbledCircuits.Language 59 | 60 | bitAnd :: Program Circuit 61 | bitAnd = buildCircuit $ do 62 | x <- input Garbler 63 | y <- input Evaluator 64 | z <- and x y 65 | return [z] 66 | ``` 67 | 68 | Next, we define a simple `main` function for `Garbler.hs`. The `*Proto` 69 | functions last argument is a pair that provide sending and recieving 70 | `ByteString`s. `simpleConn` makes such a pair out of a `Handle`, which is 71 | provided by `listenAt` and `connectTo`. See `Crypto.GarbledCircuits.Network` for 72 | more details. 73 | 74 | ```haskell 75 | main :: IO () 76 | main = do 77 | args <- getArgs 78 | let port = read (args !! 0) 79 | inp = read (args !! 1) :: Bool 80 | proto = garblerProto bitAnd [inp] . simpleConn 81 | result <- listenAt port proto 82 | print result 83 | ``` 84 | 85 | We do the same for `Evaluator.hs`. 86 | 87 | ```haskell 88 | main :: IO () 89 | main = do 90 | args <- getArgs 91 | let server = args !! 0 92 | port = read (args !! 1) 93 | inp = read (args !! 2) :: Bool 94 | proto = evaluatorProto bitAnd [inp] . simpleConn 95 | result <- connectTo server port proto 96 | print result 97 | ``` 98 | 99 | Finally, once we compile, we can preform an oblivious bitwise and! The final 100 | line is the output. 101 | 102 | ```shell 103 | % ./bit-and-garbler.a 12345 True 104 | [garblerProto] circuit garbled 105 | [garblerProto] sending circuit 106 | [garblerProto] sending my input wires 107 | [garblerProto] sending key 108 | [garblerProto] performing OT 109 | [garblerProto] recieving output 110 | [garblerProto] sending ungarbled output 111 | [False] 112 | ``` 113 | 114 | ```shell 115 | % ./bit-and-evaluator.a localhost 12345 False 116 | [evaluatorProto] recieving circuit 117 | [evaluatorProto] recieving garbler input wires 118 | [evaluatorProto] recieving key 119 | [evaluatorProto] performing OT 120 | [evaluatorProto] evaluating garbled circuit 121 | <0>: in0 Garbler wl1 2c7ec10d3db507bd48357360650fa319 122 | <1>: in1 Evaluator 123 | <2>: HALFGATE <0> <1> out0 124 | wl0 1a164c333d7ab142e8388cd940f55144 125 | wl1 854e5157edd04dcbe7779dfba2a02151 126 | [eval] <2>[0,1] HalfGate result = wl0 23f6a3ac3c66315fd9915672ac1b5022 127 | [evaluatorProto] output = 128 | <2> wl0 23f6a3ac3c66315fd9915672ac1b5022 129 | [evaluatorProto] sending output wires 130 | [evaluatorProto] recieving ungarbled output 131 | [False] 132 | ``` 133 | 134 | architecture 135 | ------------ 136 | 137 | `garbled-circuits` consists of three languages: `Circuit`, `TruthTable`, and 138 | `GarbledGate`. 139 | 140 | `Circuit` is for building boolean circuits. It's the user-facing language. It's 141 | available in `Garbled.Circuits.Language`. It has smart constructors like `or` 142 | and `not` as in the example above. You can use the smart constructor to get a 143 | reference to the output, which you use as an argument to other constructors. 144 | The `CircuitBuilder` monad compiles down to a boolean circuit. 145 | 146 | `TruthTable` is an intermediate langauge between `Circuit` and `GarbledGate`. 147 | It's role is to compress gates that are possibly unary or nullary (like `not` 148 | and `const`) into the binary gates above them. The user shouldn't have to worry 149 | about TruthTable. 150 | 151 | `GarbledGate` is a garbled circuit. Each binary gate in `TruthTable` gets 152 | assigned a true and a false wire label. This wirelabel is the input 153 | to the gates above in the circuit. Each gate encrypts its output with the 154 | correct input as keys. The `Evaluator` is only able to decrypt the output 155 | corresponding to the input wires it holds, ensuring authentic output of the 156 | whole garbled circuit. 157 | 158 | todo list 159 | --------- 160 | 161 | * circuit language - done 162 | * intermediate TruthTable representation - done 163 | * garbling 164 | * AES hashing - done 165 | * crypto rng - done 166 | * garbling optimizations (free xor, half gates) - done 167 | * network boilerplate - done 168 | * oblivious transfer - in progress 169 | * find more appropriate OT - in progress 170 | * OT extension - done 171 | * haddock documentation - in progress 172 | * profiling 173 | 174 | license 175 | ------- 176 | 177 | garbled-circuits is licenced under Apache 2.0 178 | 179 | EXPERIMENTAL: USE AT YOUR OWN RISK 180 | 181 | Copyright 2015 Brent Carmer 182 | -------------------------------------------------------------------------------- /examples/adder/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Word 4 | import System.Environment 5 | 6 | import Crypto.GarbledCircuits 7 | import Crypto.GarbledCircuits.Util (word2Bits, bits2Word) 8 | 9 | import Example.Adder 10 | 11 | main :: IO () 12 | main = do 13 | args <- getArgs 14 | let server = args !! 0 15 | port = read (args !! 1) 16 | input = word2Bits $ (read (args !! 2) :: Word8) 17 | result <- connectTo server port (evaluatorProto adder8Bit input . simpleConn) 18 | print (bits2Word result :: Word8) 19 | -------------------------------------------------------------------------------- /examples/adder/Example/Adder.hs: -------------------------------------------------------------------------------- 1 | module Example.Adder where 2 | 3 | import Crypto.GarbledCircuits 4 | import Crypto.GarbledCircuits.Language as L 5 | import Crypto.GarbledCircuits.Util (bind2, err) 6 | 7 | import Control.Monad 8 | 9 | -------------------------------------------------------------------------------- 10 | -- 8 bit adder example 11 | 12 | add1Bit :: Ref Circuit -> Ref Circuit -> Ref Circuit -> Builder (Ref Circuit, Ref Circuit) 13 | add1Bit x y c = do 14 | s <- L.xor x y 15 | out <- L.xor c s 16 | cout <- bind2 L.or (L.and x y) (L.and c s) 17 | return (out, cout) 18 | 19 | addBits :: [Ref Circuit] -> [Ref Circuit] -> Builder ([Ref Circuit], Ref Circuit) 20 | addBits xs ys = do 21 | f <- L.const False 22 | builder xs ys f [] 23 | where 24 | builder [] [] c outs = return (outs, c) 25 | builder (a:as) (b:bs) c outs = do 26 | (out,c') <- add1Bit a b c 27 | builder as bs c' (out:outs) 28 | builder as bs _ _ = err "builder" ("lists of unequal length: " ++ show [as,bs]) 29 | 30 | adderNBit :: Int -> Program Circuit 31 | adderNBit n = buildCircuit $ do 32 | inp1 <- replicateM n (input Garbler) 33 | inp2 <- replicateM n (input Evaluator) 34 | (outs, _) <- addBits inp1 inp2 35 | return outs 36 | 37 | adder8Bit :: Program Circuit 38 | adder8Bit = adderNBit 8 39 | -------------------------------------------------------------------------------- /examples/adder/Garbler.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment 4 | import Data.Word 5 | 6 | import Crypto.GarbledCircuits 7 | import Crypto.GarbledCircuits.Util (word2Bits, bits2Word) 8 | 9 | import Example.Adder 10 | 11 | main :: IO () 12 | main = do 13 | args <- getArgs 14 | let port = read (args !! 0) 15 | input = word2Bits (read (args !! 1) :: Word8) 16 | result <- listenAt port (garblerProto adder8Bit input . simpleConn) 17 | print (bits2Word result :: Word8) 18 | -------------------------------------------------------------------------------- /examples/adder/adder.cabal: -------------------------------------------------------------------------------- 1 | name: adder 2 | version: 0.1.0.0 3 | license: Apache-2.0 4 | author: Brent Carmer 5 | maintainer: bcarmer@gmail.com 6 | copyright: 2015 7 | category: Crypto 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | executable adder-garbler.a 12 | default-language: Haskell2010 13 | main-is: Garbler.hs 14 | other-modules: Example.Adder 15 | build-depends: base 16 | , garbled-circuits 17 | 18 | executable adder-evaluator.a 19 | default-language: Haskell2010 20 | main-is: Evaluator.hs 21 | other-modules: Example.Adder 22 | build-depends: base 23 | , garbled-circuits 24 | -------------------------------------------------------------------------------- /examples/adder/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cabal sandbox init 4 | cabal sandbox add-source ../../ 5 | cabal install --only-dependencies 6 | cabal install --bindir=. 7 | -------------------------------------------------------------------------------- /examples/bit-and/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding (and) 4 | import System.Environment 5 | 6 | import Crypto.GarbledCircuits 7 | import Crypto.GarbledCircuits.Language 8 | 9 | bitAnd :: Program Circuit 10 | bitAnd = buildCircuit $ do 11 | x <- input Garbler 12 | y <- input Evaluator 13 | z <- and x y 14 | return [z] 15 | 16 | main :: IO () 17 | main = do 18 | args <- getArgs 19 | let server = args !! 0 20 | port = read (args !! 1) 21 | inp = read (args !! 2) :: Bool 22 | proto = evaluatorProto bitAnd [inp] . simpleConn 23 | result <- connectTo server port proto 24 | print result 25 | -------------------------------------------------------------------------------- /examples/bit-and/Garbler.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding (and) 4 | import System.Environment 5 | 6 | import Crypto.GarbledCircuits 7 | import Crypto.GarbledCircuits.Language 8 | 9 | bitAnd :: Program Circuit 10 | bitAnd = buildCircuit $ do 11 | x <- input Garbler 12 | y <- input Evaluator 13 | z <- and x y 14 | return [z] 15 | 16 | main :: IO () 17 | main = do 18 | args <- getArgs 19 | let port = read (args !! 0) 20 | inp = read (args !! 1) :: Bool 21 | proto = garblerProto bitAnd [inp] . simpleConn 22 | result <- listenAt port proto 23 | print result 24 | -------------------------------------------------------------------------------- /examples/bit-and/bit-and.cabal: -------------------------------------------------------------------------------- 1 | name: bit-and 2 | version: 0.1.0.0 3 | license: Apache-2.0 4 | author: Brent Carmer 5 | maintainer: bcarmer@gmail.com 6 | copyright: 2015 7 | category: Crypto 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | executable bit-and-garbler.a 12 | default-language: Haskell2010 13 | main-is: Garbler.hs 14 | build-depends: base >=4.7 && <4.8 15 | , garbled-circuits 16 | 17 | executable bit-and-evaluator.a 18 | default-language: Haskell2010 19 | main-is: Evaluator.hs 20 | build-depends: base >=4.7 && <4.8 21 | , garbled-circuits 22 | -------------------------------------------------------------------------------- /examples/bit-and/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cabal sandbox init 4 | cabal sandbox add-source ../../ 5 | cabal install --only-dependencies 6 | cabal install --bindir=. 7 | -------------------------------------------------------------------------------- /examples/classifier/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Data.Word 5 | import System.Environment 6 | 7 | import Crypto.GarbledCircuits 8 | import Crypto.GarbledCircuits.Util (word2Bits, bits2Word) 9 | 10 | import Example.Classifier 11 | 12 | main :: IO () 13 | main = do 14 | (server:port:args) <- getArgs 15 | let input = concat [ word2Bits (read w :: Word8) | w <- args ] 16 | result <- connectTo server (read port) (evaluatorProto gtBinary input <=< simpleConn) 17 | print (bits2Word result :: Word8) 18 | -------------------------------------------------------------------------------- /examples/classifier/Example/Classifier.hs: -------------------------------------------------------------------------------- 1 | module Example.Classifier where 2 | 3 | import Crypto.GarbledCircuits 4 | import Crypto.GarbledCircuits.Language as L 5 | import Crypto.GarbledCircuits.Util (bind2, err) 6 | 7 | import Control.Monad 8 | 9 | classifier :: Program Circuit 10 | classifier = L.buildCircuit $ do 11 | g_bytes <- replicateM 2 (L.inputs 8 Garbler) 12 | e_bytes <- replicateM 2 (L.inputs 8 Evaluator) 13 | comps <- zipWithM L.gtBinary g_bytes e_bytes 14 | res <- L.ands comps 15 | return [res] 16 | 17 | -- to compare two numbers [0-127] 18 | -- return 1 if the first number is bigger, return 0 otherwise 19 | gtBinary :: Program Circuit 20 | gtBinary = L.buildCircuit $ do 21 | g_bytes <- L.inputs 8 Garbler 22 | e_bytes <- L.inputs 8 Evaluator 23 | res <- L.gtBinary g_bytes e_bytes 24 | return [res] 25 | -------------------------------------------------------------------------------- /examples/classifier/Garbler.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Data.Word 5 | import System.Environment 6 | 7 | import Crypto.GarbledCircuits 8 | import Crypto.GarbledCircuits.Util (word2Bits, bits2Word) 9 | 10 | import Example.Classifier 11 | 12 | main :: IO () 13 | main = do 14 | (port:args) <- getArgs 15 | let input = concat [ word2Bits (read w :: Word8) | w <- args ] 16 | result <- listenAt (read port) (garblerProto gtBinary input <=< simpleConn) 17 | print (bits2Word result :: Word8) 18 | -------------------------------------------------------------------------------- /examples/classifier/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cabal sandbox init 4 | cabal sandbox add-source ../../ 5 | cabal install --only-dependencies 6 | cabal install --bindir=. 7 | -------------------------------------------------------------------------------- /examples/classifier/classifier.cabal: -------------------------------------------------------------------------------- 1 | name: classifier 2 | version: 0.1.0.0 3 | license: Apache-2.0 4 | author: Brent Carmer 5 | maintainer: bcarmer@gmail.com 6 | copyright: 2015 7 | category: Crypto 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | executable classifier-garbler.a 12 | default-language: Haskell2010 13 | main-is: Garbler.hs 14 | other-modules: Example.Classifier 15 | build-depends: base 16 | , garbled-circuits 17 | 18 | executable classifier-evaluator.a 19 | default-language: Haskell2010 20 | main-is: Evaluator.hs 21 | other-modules: Example.Classifier 22 | build-depends: base 23 | , garbled-circuits 24 | -------------------------------------------------------------------------------- /garbled-circuits.cabal: -------------------------------------------------------------------------------- 1 | name: garbled-circuits 2 | version: 0.0.1.0 3 | synopsis: Modern garbled circuit implementation. 4 | description: 5 | Describe a program as a circuit and create a two-party secure computation protocol. 6 | . 7 | Uses the latest optimizations to reduce communication including free-xor and half-gates. 8 | . 9 | Uses AES-based garbling with AESNI support. 10 | license: Apache-2.0 11 | license-file: LICENSE 12 | author: Brent Carmer 13 | homepage: https://github.com/spaceships/garbled-circuits 14 | bug-reports: https://github.com/spaceships/garbled-circuits/issues 15 | maintainer: bcarmer@gmail.com 16 | copyright: 2015 17 | category: Cryptography 18 | build-type: Simple 19 | cabal-version: >=1.12 20 | 21 | library 22 | default-language: Haskell2010 23 | hs-source-dirs: src 24 | exposed-modules: Crypto.GarbledCircuits 25 | , Crypto.GarbledCircuits.Types 26 | , Crypto.GarbledCircuits.Util 27 | , Crypto.GarbledCircuits.Language 28 | , Crypto.GarbledCircuits.TruthTable 29 | , Crypto.GarbledCircuits.Encryption 30 | , Crypto.GarbledCircuits.GarbledGate 31 | , Crypto.GarbledCircuits.Eval 32 | , Crypto.GarbledCircuits.ObliviousTransfer 33 | , Crypto.GarbledCircuits.Network 34 | build-depends: base 35 | , bytestring 36 | , cereal 37 | , cipher-aes128 38 | , containers 39 | , crypto-numbers 40 | , crypto-random 41 | , entropy 42 | , mtl 43 | , network 44 | , split 45 | 46 | ghc-options: -fwarn-incomplete-patterns 47 | default-language: Haskell2010 48 | default-extensions: CPP 49 | -- cpp-options: -DDEBUG 50 | 51 | source-repository head 52 | type: git 53 | location: https://github.com/spaceships/garbled-circuits 54 | 55 | test-suite test-garbled-circuits 56 | default-language: Haskell2010 57 | type: exitcode-stdio-1.0 58 | main-is: Main.hs 59 | other-modules: TestGarbledCircuits 60 | , TestObliviousTransfer 61 | hs-source-dirs: test 62 | , examples/adder 63 | build-depends: base 64 | , QuickCheck 65 | , bytestring 66 | , cereal 67 | , cipher-aes128 68 | , containers 69 | , crypto-numbers 70 | , entropy 71 | , garbled-circuits 72 | , test-framework 73 | , test-framework-quickcheck2 74 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, RankNTypes #-} 2 | 3 | module Crypto.GarbledCircuits ( 4 | -- * Garbled Circuit datatypes 5 | Circuit (..) 6 | , Program (..) 7 | , Party (..) 8 | , Ref (..) 9 | -- * The garbled circuit protocols 10 | , Connection (..) 11 | , garblerProto 12 | , evaluatorProto 13 | -- ** Simple socket connection 14 | , connectTo 15 | , listenAt 16 | , simpleConn 17 | ) 18 | where 19 | 20 | import Crypto.GarbledCircuits.GarbledGate 21 | import Crypto.GarbledCircuits.TruthTable 22 | import Crypto.GarbledCircuits.Eval 23 | import Crypto.GarbledCircuits.Types 24 | import Crypto.GarbledCircuits.Util 25 | import Crypto.GarbledCircuits.Network 26 | import Crypto.GarbledCircuits.ObliviousTransfer 27 | 28 | import Control.Monad 29 | import Crypto.Cipher.AES128 (AESKey128) 30 | import Data.Functor 31 | import qualified Data.ByteString.Char8 as BS 32 | import Data.Serialize (decode, encode, Serialize) 33 | import Network.Socket hiding (send, recv) 34 | import Network.BSD 35 | import System.IO 36 | import Text.Printf 37 | 38 | garblerProto :: Program Circuit -> [Bool] -> Connection -> IO [Bool] 39 | garblerProto prog inp conn = do 40 | (gg, ctx) <- garble prog 41 | traceM "[garblerProto] circuit garbled" 42 | let myWires = inputWires Garbler gg ctx inp 43 | theirPairs = map asTuple $ inputPairs Evaluator gg ctx 44 | printf "[garblerProto] sending garbled circuit (size=%d)\n" (byteSize (halfGates gg)) 45 | send conn (halfGates gg) 46 | traceM "[garblerProto] sending my input wires" 47 | send conn myWires 48 | traceM "[garblerProto] sending key" 49 | send conn (ctx_key ctx) 50 | traceM "[garblerProto] performing OT" 51 | otSend conn (ctx_key ctx) theirPairs 52 | traceM "[garblerProto] recieving output" 53 | wires <- recv conn 54 | let result = map (ungarble ctx) wires 55 | traceM "[garblerProto] sending ungarbled output" 56 | send conn result 57 | printConnectionInfo conn 58 | return result 59 | 60 | evaluatorProto :: Program Circuit -> [Bool] -> Connection -> IO [Bool] 61 | evaluatorProto prog inp conn = do 62 | let tt = circ2tt prog 63 | traceM "[evaluatorProto] recieving circuit" 64 | hgs <- recv conn :: IO [(Wirelabel,Wirelabel)] 65 | traceM "[evaluatorProto] recieving garbler input wires" 66 | inpGb <- recv conn :: IO [Wirelabel] 67 | traceM "[evaluatorProto] recieving key" 68 | key <- recv conn :: IO AESKey128 69 | traceM "[evaluatorProto] performing OT" 70 | inpEv <- otRecv conn key inp 71 | traceM "[evaluatorProto] evaluating garbled circuit" 72 | let gg = reconstruct tt hgs 73 | out = eval gg key inpGb inpEv 74 | traceM ("[evaluatorProto] output =\n" ++ showOutput (prog_output gg) out) 75 | traceM "[evaluatorProto] sending output wires" 76 | send conn out 77 | traceM "[evaluatorProto] recieving ungarbled output" 78 | result <- recv conn 79 | printConnectionInfo conn 80 | return result 81 | 82 | -------------------------------------------------------------------------------- 83 | -- ot 84 | 85 | showOutput :: [Ref GarbledGate] -> [Wirelabel] -> String 86 | showOutput refs = init . unlines . zipWith (\r w -> "\t" ++ show r ++ " " ++ showWirelabel w) refs 87 | 88 | asTuple :: WirelabelPair -> (Wirelabel, Wirelabel) 89 | asTuple p = (wlp_false p, wlp_true p) 90 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/Encryption.hs: -------------------------------------------------------------------------------- 1 | module Crypto.GarbledCircuits.Encryption 2 | ( genKey 3 | , genR 4 | , hash 5 | , randBlock 6 | , randBool 7 | , updateKey 8 | , lpad 9 | , rpad 10 | , updateR 11 | ) 12 | where 13 | 14 | import Crypto.GarbledCircuits.Types 15 | import Crypto.GarbledCircuits.Util 16 | 17 | import qualified Data.ByteString as BS 18 | import Control.Monad.State 19 | import Crypto.Cipher.AES128 20 | import Data.Bits ((.&.), (.|.)) 21 | import qualified Data.Bits as Bits 22 | import Data.Maybe 23 | import qualified Data.Serialize as Ser 24 | import Data.Word 25 | import Data.Functor 26 | import System.Entropy 27 | 28 | -------------------------------------------------------------------------------- 29 | -- encryption and decryption for wirelabels 30 | 31 | -- The AES-based hash function from the halfgates paper (p8) 32 | -- Uses native hw instructions if available 33 | hash :: AESKey128 -> ByteString -> Int -> ByteString 34 | hash key x i = encryptBlock key k `xorBytes` k 35 | where 36 | k = double x `xorBytes` rpad 16 (Ser.encode i) 37 | 38 | rpad :: Int -> ByteString -> ByteString 39 | rpad n ct = BS.append (BS.replicate (n - BS.length ct) 0) ct 40 | 41 | lpad :: Int -> ByteString -> ByteString 42 | lpad n ct = BS.append ct (BS.replicate (n - BS.length ct) 0) 43 | 44 | double :: ByteString -> ByteString 45 | double c = BS.pack result 46 | where 47 | (xs, carry) = shiftLeft (BS.unpack c) 48 | result = if carry > 0 then xorWords xs irreducible else xs 49 | 50 | irreducible :: [Word8] 51 | irreducible = replicate 15 0 ++ [86] 52 | 53 | shiftLeft :: [Word8] -> ([Word8], Word8) 54 | shiftLeft [] = ([], 0) 55 | shiftLeft (b:bs) = let (bs', c) = shiftLeft bs 56 | msb = Bits.shiftR b 7 57 | b' = Bits.shiftL b 1 .|. c 58 | in (b':bs', msb) 59 | 60 | genKey :: Garble AESKey128 61 | genKey = do 62 | key <- randBlock 63 | let k = fromMaybe (err "genKey" "bad key") (buildKey key) 64 | return k 65 | 66 | genR :: Garble Wirelabel 67 | genR = do 68 | b <- randBlock 69 | let color = rpad 16 $ Ser.encode (1 :: Int) 70 | wl = orBytes color b 71 | return wl 72 | 73 | randBlock :: Garble ByteString 74 | randBlock = liftIO (getEntropy 16) 75 | 76 | randBool :: Garble Bool 77 | randBool = do 78 | w8 <- BS.head <$> liftIO (getEntropy 1) 79 | return (w8 .&. 1 > 0) 80 | 81 | updateKey :: AESKey128 -> Garble () 82 | updateKey k = lift.lift $ modify (\st -> st { ctx_key = k }) 83 | 84 | updateR :: Wirelabel -> Garble () 85 | updateR r = lift.lift $ modify (\st -> st { ctx_r = r }) 86 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/Eval.hs: -------------------------------------------------------------------------------- 1 | module Crypto.GarbledCircuits.Eval 2 | ( evalLocal 3 | , eval 4 | ) 5 | where 6 | 7 | import Crypto.GarbledCircuits.Encryption 8 | import Crypto.GarbledCircuits.Types 9 | import Crypto.GarbledCircuits.Util 10 | 11 | import Control.Arrow (first, second) 12 | import Control.Monad.State 13 | import Control.Monad.Reader 14 | import Crypto.Cipher.AES128 15 | import Data.Functor 16 | import Data.List (elemIndex) 17 | import qualified Data.Map as M 18 | import Data.Maybe 19 | import qualified Data.Set as S 20 | 21 | -------------------------------------------------------------------------------- 22 | -- garbled evaluator 23 | 24 | type ResultMap = Map (Ref GarbledGate) Wirelabel 25 | type Eval = ReaderT AESKey128 (State (Int, ResultMap)) 26 | 27 | runEval :: AESKey128 -> ResultMap -> Eval a -> ResultMap 28 | runEval k m ev = snd $ execState (runReaderT ev k) (0,m) 29 | 30 | eval :: Program GarbledGate -> AESKey128 -> [Wirelabel] -> [Wirelabel] -> [Wirelabel] 31 | eval prog key inpGb inpEv = trace (showGG prog inpGb inpEv) result 32 | where 33 | initialResults = M.fromList (zip (sortedInput readGGInput Garbler prog) inpGb) `M.union` 34 | M.fromList (zip (sortedInput readGGInput Evaluator prog) inpEv) 35 | resultMap = runEval key initialResults (eval' prog) 36 | result = map (resultMap !!!) (prog_output prog) 37 | 38 | eval' :: Program GarbledGate -> Eval () 39 | eval' prog = mapM_ evalRef (nonInputRefs prog) 40 | where 41 | evalRef ref = do 42 | let c = lookupC ref prog 43 | kids <- mapM getResult (children c) 44 | result <- construct c kids 45 | insertResult ref result 46 | traceM ("[eval] " ++ show ref ++ show (unRef `fmap` children c) 47 | ++ " " ++ typeOf c ++ " result = " ++ showWirelabel result) 48 | 49 | construct :: GarbledGate -> [Wirelabel] -> Eval Wirelabel 50 | construct (FreeXor _ _ ) [a,b] = 51 | return (a `xorBytes` b) 52 | construct (HalfGate _ _ g e) [a,b] = do 53 | j1 <- nextIndex 54 | j2 <- nextIndex 55 | k <- ask 56 | let wg = hash k a j1 `xorBytes` (lsb a `mask` g) 57 | we = hash k b j2 `xorBytes` (lsb b `mask` (e `xorBytes` a)) 58 | return (wg `xorBytes` we) 59 | construct gate args = err "construct" ("unknown pattern: \n" ++ show gate ++ "\n" ++ show args) 60 | 61 | nextIndex :: Eval Int 62 | nextIndex = do 63 | c <- gets fst 64 | modify (first succ) 65 | return c 66 | 67 | getResult :: Ref GarbledGate -> Eval Wirelabel 68 | getResult ref = fromMaybe (err "getResult" "no ref") <$> (M.lookup ref <$> gets snd) 69 | 70 | insertResult :: Ref GarbledGate -> Wirelabel -> Eval () 71 | insertResult ref result = modify $ second (M.insert ref result) 72 | 73 | nonInputRefs :: Program c -> [Ref c] 74 | nonInputRefs prog = filter (not.isInput) (M.keys (prog_env prog)) 75 | where 76 | isInput ref = S.member ref (S.union (prog_input_gb prog) (prog_input_ev prog)) 77 | 78 | -- evaluate a garbled circuit locally 79 | evalLocal :: [Bool] -> [Bool] -> (Program GarbledGate, Context) -> [Bool] 80 | evalLocal inpGb inpEv (prog, ctx) = 81 | trace (showPairs ctx ++ "[evalLocal] result = " ++ show result) result 82 | where 83 | result = map (ungarble ctx) outs 84 | outs = eval prog (ctx_key ctx) aWires bWires 85 | aWires = inputWires Garbler prog ctx inpGb 86 | bWires = inputWires Evaluator prog ctx inpEv 87 | 88 | typeOf :: GarbledGate -> String 89 | typeOf (GarbledInput _ _) = "Input" 90 | typeOf (FreeXor _ _) = "FreeXor" 91 | typeOf (HalfGate {}) = "HalfGate" 92 | 93 | showGG :: Program GarbledGate -> [Wirelabel] -> [Wirelabel] -> String 94 | showGG prog inpGb inpEv = init $ unlines $ map showGate (M.toList (prog_env prog)) 95 | where 96 | showGate (ref, gg) = show ref ++ ": " ++ case gg of 97 | GarbledInput i p -> show i ++ " " ++ show p ++ " " ++ outp ref ++ partyInput p i 98 | FreeXor x y -> "FREEXOR " ++ show x ++ " " ++ show y ++ " " ++ outp ref 99 | HalfGate x y g e -> "HALFGATE " ++ show x ++ " " ++ show y ++ " " ++ outp ref ++ "\n" 100 | ++ "\t" ++ showWirelabel g ++ "\n" 101 | ++ "\t" ++ showWirelabel e 102 | outp r = case r `elemIndex` prog_output prog 103 | of Just i -> "out" ++ show i; _ -> "" 104 | 105 | partyInput Garbler (InputId i) | length inpGb > i = showWirelabel (inpGb !! i) 106 | partyInput Evaluator (InputId i) | length inpEv > i = showWirelabel (inpEv !! i) 107 | partyInput _ _ = "" 108 | 109 | showPairs :: Context -> String 110 | showPairs ctx = 111 | "--------------------------------------------------------------------------------\n" 112 | ++ "-- pairs \n" ++ concatMap showPair (M.toList (ctx_pairs ctx)) 113 | where 114 | showPair (ref, pair) = show ref ++ ": true=" ++ showWirelabel (wlp_true pair) 115 | ++ " false=" ++ showWirelabel (wlp_false pair) ++ "\n" 116 | 117 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/GarbledGate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, NamedFieldPuns #-} 2 | 3 | module Crypto.GarbledCircuits.GarbledGate 4 | ( 5 | GarbledGate (..) 6 | , garble 7 | , halfGates 8 | , newWirelabels 9 | , reconstruct 10 | , runGarble 11 | , runGarble' 12 | , tt2gg 13 | ) 14 | where 15 | 16 | import Crypto.GarbledCircuits.Encryption 17 | import Crypto.GarbledCircuits.TruthTable 18 | import Crypto.GarbledCircuits.Types 19 | import Crypto.GarbledCircuits.Util 20 | 21 | import Control.Monad.Reader 22 | import Control.Monad.State 23 | import Crypto.Cipher.AES128 (AESKey128) 24 | import qualified Data.Bits 25 | import Data.Functor 26 | import qualified Data.Map as M 27 | import qualified Data.Set as S 28 | import Data.Tuple (swap) 29 | 30 | -------------------------------------------------------------------------------- 31 | -- garble a truthtable program 32 | 33 | garble :: Program Circuit -> IO (Program GarbledGate, Context) 34 | garble = tt2gg . circ2tt 35 | 36 | runGarble :: Program TruthTable -> Garble a -> IO (Program GarbledGate, Context) 37 | runGarble prog_tt g = do 38 | ((_, p), c) <- runGarble' prog_tt g 39 | return (p, c) 40 | 41 | runGarble' :: Program TruthTable -> Garble a -> IO ((a, Program GarbledGate), Context) 42 | runGarble' prog_tt = 43 | flip runStateT emptyContext 44 | . flip runReaderT prog_tt 45 | . flip runStateT emptyProg 46 | 47 | tt2gg :: Program TruthTable -> IO (Program GarbledGate, Context) 48 | tt2gg prog_tt = do 49 | (prog_gg, ctx) <- runGarble prog_tt $ do 50 | updateKey =<< genKey 51 | updateR =<< genR 52 | -- TT refs are topologically ordered 53 | mapM_ garbleGate (M.keys (prog_env prog_tt)) 54 | let outs = map convertRef (prog_output prog_tt) 55 | prog_gg' = prog_gg { prog_output = outs } 56 | return (prog_gg', ctx) 57 | 58 | garbleGate :: Ref TruthTable -> Garble (Ref GarbledGate) 59 | garbleGate tt_ref = lookupTT tt_ref >>= \case -- get the TruthTable 60 | TTInp i p -> do -- if it's an input: 61 | pair <- newWirelabels -- get new wirelabels 62 | gg_ref <- inputp p (GarbledInput i p) -- make it a gate, get a ref 63 | updateContext gg_ref pair -- show our work 64 | return gg_ref -- return the gate ref 65 | tt -> do -- otherwise: 66 | gg_ref <- nextRef -- get a new ref 67 | let xref = convertRef (tt_inpx tt) -- get a ref to the left child gate 68 | yref = convertRef (tt_inpy tt) -- get a ref to the right child gate 69 | (gate, out_wl) <- encode tt xref yref -- create the garbled table 70 | writep gg_ref gate -- associate ref with garbled gate 71 | updateContext gg_ref out_wl -- show our work 72 | return gg_ref -- return the new gate ref 73 | 74 | encode :: TruthTable -- the TruthTable 75 | -> Ref GarbledGate -- left child ref 76 | -> Ref GarbledGate -- right child ref 77 | -> Garble (GarbledGate, WirelabelPair) 78 | encode tt aref bref 79 | | isXor tt = do 80 | a_pair <- maybeFlipWires (tt_negx tt) <$> pairsLookup aref 81 | b_pair <- maybeFlipWires (tt_negy tt) <$> pairsLookup bref 82 | r <- getR 83 | let c0 = wlp_false a_pair `xorBytes` wlp_false b_pair 84 | return (FreeXor aref bref, (WirelabelPair c0 (c0 `xorBytes` r))) 85 | 86 | | halfGateCompatible tt = do -- the truth table is half-gate compatible 87 | let (fg, a, b) = getFg (tt_f tt) 88 | k <- getKey 89 | r <- getR 90 | a_pair <- maybeFlipWires (tt_negx tt) <$> pairsLookup aref 91 | b_pair <- maybeFlipWires (tt_negy tt) <$> pairsLookup bref 92 | let pa = lsb (wlp_false a_pair) 93 | pb = lsb (wlp_false b_pair) 94 | j <- nextIndex 95 | j' <- nextIndex 96 | let g = hash k (wlp_false a_pair) j `xorBytes` hash k (wlp_true a_pair) j 97 | `xorBytes` mask (Data.Bits.xor pb b) r 98 | wg = hash k (sel pa a_pair) j `xorBytes` mask (fg pa pb) r 99 | e = hash k (wlp_false b_pair) j' `xorBytes` hash k (wlp_true b_pair) j' 100 | `xorBytes` sel a a_pair 101 | we = hash k (sel pb b_pair) j' 102 | w = wg `xorBytes` we 103 | wlp = WirelabelPair { wlp_false = w, wlp_true = w `xorBytes` r } 104 | return (HalfGate aref bref g e, wlp) 105 | 106 | | otherwise = err "encode" ("unsupported gate: " ++ show tt) 107 | 108 | newWirelabels :: Garble WirelabelPair 109 | newWirelabels = do 110 | a <- randBlock 111 | r <- getR 112 | return WirelabelPair { wlp_false = a, wlp_true = a `xorBytes` r } 113 | 114 | halfGates :: Program GarbledGate -> [(Wirelabel, Wirelabel)] 115 | halfGates = map vals . filter halfGate . map snd . M.toList . prog_env 116 | where 117 | halfGate (HalfGate {}) = True 118 | halfGate _ = False 119 | vals (HalfGate _ _ g e) = (g,e) 120 | vals _ = err "halfGates" "not half gate" 121 | 122 | -- create a Program GarbledGate given a TruthTable and a list of HalfGates 123 | reconstruct :: Program TruthTable -> [(Wirelabel, Wirelabel)] -> Program GarbledGate 124 | reconstruct prog hgs = Program { prog_input_gb = S.map convertRef (prog_input_gb prog) 125 | , prog_input_ev = S.map convertRef (prog_input_ev prog) 126 | , prog_output = map convertRef (prog_output prog) 127 | , prog_env = M.fromList (doStuff (M.toList (prog_env prog)) hgs) 128 | } 129 | 130 | doStuff :: [(Ref TruthTable, TruthTable)] 131 | -> [(Wirelabel, Wirelabel)] 132 | -> [(Ref GarbledGate, GarbledGate)] 133 | doStuff [] _ = [] 134 | doStuff ((ref,tt):rest) hs = 135 | let (gg,hs') = case tt of { 136 | TTInp i p -> (GarbledInput i p, hs); 137 | _ -> case tt_f tt of 138 | XOR -> (FreeXor (convertRef (tt_inpx tt)) (convertRef (tt_inpy tt)), hs); 139 | _ -> (HalfGate (convertRef (tt_inpx tt)) (convertRef (tt_inpy tt)) (fst (head hs)) (snd (head hs)), tail hs); 140 | } 141 | in (convertRef ref, gg) : doStuff rest hs' 142 | 143 | -------------------------------------------------------------------------------- 144 | -- helpers 145 | 146 | maybeFlipWires :: Bool -> WirelabelPair -> WirelabelPair 147 | maybeFlipWires False wlp = wlp 148 | maybeFlipWires True wlp = WirelabelPair { wlp_true = wlp_false wlp 149 | , wlp_false = wlp_true wlp 150 | } 151 | 152 | isXor :: TruthTable -> Bool 153 | isXor tt = tt_f tt == XOR 154 | 155 | halfGateCompatible :: TruthTable -> Bool 156 | halfGateCompatible tt = tt_f tt == AND || tt_f tt == OR 157 | 158 | getFg :: Operation -> (Bool -> Bool -> Bool, Bool, Bool) 159 | getFg op = case op of 160 | AND -> (fg False False False, False, False) 161 | OR -> (fg True True True, True, True) 162 | _ -> err "getFg" ("unsupported op: " ++ show op) 163 | where 164 | fg a b c x y = Data.Bits.xor (Data.Bits.xor a x && Data.Bits.xor b y) c 165 | 166 | nextIndex :: Garble Int 167 | nextIndex = do 168 | c <- lift.lift $ get 169 | let c' = ctx_ctr c 170 | lift.lift $ put c { ctx_ctr = succ c' } 171 | return c' 172 | 173 | getKey :: Garble AESKey128 174 | getKey = lift.lift $ gets ctx_key 175 | 176 | getR :: Garble Wirelabel 177 | getR = lift.lift $ gets ctx_r 178 | 179 | lookupTT :: Ref TruthTable -> Garble TruthTable 180 | lookupTT ref = asks (lookupC ref) 181 | 182 | pairsLookup :: Ref GarbledGate -> Garble WirelabelPair 183 | pairsLookup ref = lift.lift $ gets (M.lookup ref . ctx_pairs) >>= \case 184 | Nothing -> err "pairsLookup" ("no ref: " ++ show ref) 185 | Just pair -> return pair 186 | 187 | updateContext :: Ref GarbledGate -> WirelabelPair -> Garble () 188 | updateContext refgg pair = do 189 | pairsInsert refgg pair 190 | truthInsert (wlp_true pair) True 191 | truthInsert (wlp_false pair) False 192 | 193 | pairsInsert :: Ref GarbledGate -> WirelabelPair -> Garble () 194 | pairsInsert ref pair = 195 | lift.lift $ modify (\st -> st { ctx_pairs = M.insert ref pair (ctx_pairs st) }) 196 | 197 | truthInsert :: Wirelabel -> Bool -> Garble () 198 | truthInsert l b = 199 | lift.lift $ modify (\st -> st { ctx_truth = M.insert l b (ctx_truth st) }) 200 | 201 | convertRef :: Ref a -> Ref b 202 | convertRef = Ref . unRef 203 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/Language.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Crypto.GarbledCircuits.Language 3 | Description : A language for creating boolean circuits. 4 | License : Apache-2.0 5 | Maintainer : Brent Carmer 6 | Stability : experimental 7 | 8 | This module provides a language for creating @Program Circuit@s. 9 | 10 | The general idea is that we use the constructors to generate @Ref@s to circuit structures. Then, the 11 | @Builder@ monad makes sure repeated structures get reused. 12 | 13 | When you are making a circuit, you can think of a @Ref@ as a circuit's output. 14 | 15 | -} 16 | 17 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 18 | 19 | module Crypto.GarbledCircuits.Language 20 | -- ( 21 | -- -- * Building and Evaluating Circuits 22 | -- Builder 23 | -- , buildCircuit 24 | -- , evalCircuit 25 | -- -- * Smart Constructors 26 | -- -- |Use these constructors to create boolean circuits in the 'Builder' monad. 27 | -- , input 28 | -- , xor 29 | -- , and 30 | -- , or 31 | -- , not 32 | -- , const 33 | -- ) 34 | where 35 | 36 | import Prelude hiding (and, not, or, const) 37 | import qualified Prelude 38 | 39 | import Crypto.GarbledCircuits.Types 40 | import Crypto.GarbledCircuits.Util hiding (nextRef) 41 | 42 | import Control.Applicative hiding (Const) 43 | import Control.Monad (zipWithM) 44 | import Control.Monad.State 45 | import qualified Data.Bits 46 | import qualified Data.Map as M 47 | import qualified Data.Set as S 48 | import Data.Word 49 | 50 | data CircuitSt = CircuitSt { st_nextRef :: Ref Circuit 51 | , st_input_gb :: S.Set (Ref Circuit) 52 | , st_input_ev :: S.Set (Ref Circuit) 53 | , st_nextInputId :: InputId 54 | , st_deref_env :: Map (Ref Circuit) Circuit 55 | , st_dedup_env :: Map Circuit (Ref Circuit) 56 | } 57 | 58 | newtype Builder a = Builder (State CircuitSt a) 59 | deriving (Functor, Applicative, Monad, MonadState CircuitSt) 60 | 61 | -- |Evaluate a program in plaintext. Useful for testing and debugging. 62 | evalCircuit :: [Bool] -- ^ Garbler's input 63 | -> [Bool] -- ^ Evaluator's input 64 | -> Program Circuit -- ^ The program itself 65 | -> [Bool] -- ^ The computed output 66 | evalCircuit inpGb inpEv prog = evalProg construct prog 67 | where 68 | inputs Garbler = M.fromList (zip (S.toList (prog_input_gb prog)) inpGb) 69 | inputs Evaluator = M.fromList (zip (S.toList (prog_input_ev prog)) inpEv) 70 | 71 | construct :: Ref Circuit -> Circuit -> [Bool] -> Bool 72 | construct ref (Input i p) [] = case M.lookup ref (inputs p) of 73 | Just b -> b 74 | Nothing -> err "reconstruct" ("no input with id " ++ show i) 75 | construct _ (Const x) [] = x 76 | construct _ (Not _) [x] = Prelude.not x 77 | construct _ (Xor _ _) [x,y] = Data.Bits.xor x y 78 | construct _ (And _ _) [x,y] = x && y 79 | construct _ (Or _ _) [x,y] = x || y 80 | construct _ _ _ = err "reconstruct" "unrecognized pattern" 81 | 82 | -- |Create a program from smart constructors. Top level 'Ref's are treated as output. 83 | -- 84 | -- Note: programs with toplevel 'Not' or 'Const' are not garbleable. 85 | buildCircuit :: Builder [Ref Circuit] -> Program Circuit 86 | buildCircuit (Builder c) = Program { prog_input_gb = st_input_gb st 87 | , prog_input_ev = st_input_ev st 88 | , prog_output = reverse outs 89 | , prog_env = st_deref_env st 90 | } 91 | where 92 | (outs, st) = runState c emptySt 93 | emptySt = CircuitSt { st_nextRef = Ref 0 94 | , st_nextInputId = InputId 0 95 | , st_input_gb = S.empty 96 | , st_input_ev = S.empty 97 | , st_deref_env = emptyEnv 98 | , st_dedup_env = M.empty 99 | } 100 | 101 | lookupCircuit :: Circuit -> Builder (Maybe (Ref Circuit)) 102 | lookupCircuit circ = do 103 | dedupEnv <- gets st_dedup_env 104 | return $ M.lookup circ dedupEnv 105 | 106 | insertRef :: Ref Circuit -> Circuit -> Builder () 107 | insertRef ref circ = do 108 | derefEnv <- gets st_deref_env 109 | dedupEnv <- gets st_dedup_env 110 | modify $ \st -> st { st_deref_env = M.insert ref circ derefEnv 111 | , st_dedup_env = M.insert circ ref dedupEnv 112 | } 113 | 114 | nextRef :: Builder (Ref Circuit) 115 | nextRef = do 116 | ref <- gets st_nextRef 117 | modify (\st -> st { st_nextRef = succ ref }) 118 | return ref 119 | 120 | nextInputId :: Builder InputId 121 | nextInputId = do 122 | i <- gets st_nextInputId 123 | modify $ \st -> st { st_nextInputId = succ i } 124 | return i 125 | 126 | intern :: Circuit -> Builder (Ref Circuit) 127 | intern circ = do 128 | maybeRef <- lookupCircuit circ 129 | case maybeRef of 130 | Just ref -> return ref 131 | Nothing -> do 132 | ref <- nextRef 133 | insertRef ref circ 134 | return ref 135 | 136 | -------------------------------------------------------------------------------- 137 | -- smart constructors for the Circuit language 138 | 139 | -- |The 'input' function creates an input bit for the 'Garbler' or the 'Evaluator'. 140 | input :: Party -> Builder (Ref Circuit) 141 | input p = do i <- nextInputId 142 | ref <- intern (Input i p) 143 | modify $ \st -> case p of 144 | Garbler -> st { st_input_gb = S.insert ref (st_input_gb st) } 145 | Evaluator -> st { st_input_ev = S.insert ref (st_input_ev st) } 146 | return ref 147 | 148 | inputs :: Int -> Party -> Builder [Ref Circuit] 149 | inputs n p = replicateM n (input p) 150 | 151 | -- |Bitwise xor. This gate will be garbled as a 'FreeXor'. 152 | xor :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 153 | xor x y = intern (Xor x y) 154 | 155 | -- |Bitwise and. This gate will be garbled as a 'HalfGate'. 156 | and :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 157 | and x y = intern (And x y) 158 | 159 | ands :: [Ref Circuit] -> Builder (Ref Circuit) 160 | ands [x] = return x 161 | ands (x:xs) = and x =<< ands xs 162 | 163 | -- |Bitwise or. This gate will be garbled as a 'HalfGate'. 164 | or :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 165 | or x y = intern (Or x y) 166 | 167 | -- |Bitwise negation. 168 | -- This gate will be folded into a binary gate above it in the circuit. 169 | -- 170 | -- Note: programs with toplevel 'Not' or 'Const' are not garbleable. 171 | not :: Ref Circuit -> Builder (Ref Circuit) 172 | not x = intern (Not x) 173 | 174 | -- |Create a constant value. 175 | -- This gate will be folded into a binary gate above it in the circuit. 176 | -- 177 | -- Note: programs with toplevel 'Not' or 'Const' are not garbleable. 178 | const :: Bool -> Builder (Ref Circuit) 179 | const b = intern (Const b) 180 | 181 | -------------------------------------------------------------------------------- 182 | -- high level constructors 183 | 184 | ifThenElse :: Ref Circuit -> Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 185 | ifThenElse cond a b = bind2 or (and cond a) (and b =<< not cond) 186 | 187 | -- |Compare two bits. 188 | eqBit :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 189 | eqBit x y = bind2 or (and x y) (bind2 and (not x) (not y)) 190 | 191 | ltBit :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 192 | ltBit x y = and y =<< not x 193 | 194 | -- |Compare two bits. 195 | leqBit :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 196 | leqBit x y = or y =<< not x 197 | 198 | -- |Compare two bits. 199 | gtBit :: Ref Circuit -> Ref Circuit -> Builder (Ref Circuit) 200 | gtBit x y = not =<< leqBit x y 201 | 202 | -- |Compare two little-endian binary values. 203 | -- 204 | gtBinary :: [Ref Circuit] -> [Ref Circuit] -> Builder (Ref Circuit) 205 | gtBinary xs ys = fst <$> gtHelper xs ys 206 | where 207 | gtHelper [x] [y] = do 208 | gt <- gtBit x y 209 | eq <- eqBit x y 210 | return (gt, eq) 211 | gtHelper (x:xs) (y:ys) = do 212 | (restGt, restEq) <- gtHelper xs ys 213 | thisGt <- gtBit x y 214 | thisEq <- eqBit x y 215 | gt <- ifThenElse restEq thisGt restGt 216 | eq <- and restEq thisEq 217 | return (gt, eq) 218 | gtHelper _ _ = undefined 219 | 220 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/Network.hs: -------------------------------------------------------------------------------- 1 | module Crypto.GarbledCircuits.Network 2 | ( byteSize 3 | , simpleConn 4 | , send 5 | , recv 6 | , send2 7 | , recv2 8 | , send4 9 | , recv4 10 | , connectTo 11 | , listenAt 12 | , printConnectionInfo 13 | ) 14 | where 15 | 16 | import Crypto.GarbledCircuits.Types 17 | import Crypto.GarbledCircuits.Util 18 | 19 | import Control.Monad 20 | import qualified Data.ByteString.Char8 as BS 21 | import Data.Functor 22 | import Data.Serialize (decode, encode, Serialize) 23 | import Network.Socket hiding (send, recv) 24 | import Network.BSD 25 | import System.IO 26 | import Data.IORef 27 | import Text.Printf 28 | 29 | -------------------------------------------------------------------------------- 30 | -- network 31 | 32 | byteSize :: Serialize a => a -> Int 33 | byteSize = BS.length . encode 34 | 35 | simpleConn :: Handle -> IO Connection 36 | simpleConn h = do 37 | zero0 <- newIORef 0 38 | zero1 <- newIORef 0 39 | Connection (BS.hPut h) (BS.hGet h) <$> newIORef 0 <*> newIORef 0 40 | 41 | send :: Serialize a => Connection -> a -> IO () 42 | send c x = do 43 | let encoding = encode x; n = BS.length encoding 44 | conn_send c (encode n) 45 | conn_send c encoding 46 | modifyIORef' (conn_bytes_sent c) (+ (n+8)) 47 | 48 | recv :: Serialize a => Connection -> IO a 49 | recv c = do 50 | num <- conn_recv c 8 51 | let n = either (err "recieve") id (decode num) 52 | str <- conn_recv c n 53 | modifyIORef' (conn_bytes_received c) (+ (n+8)) 54 | either (err "recv") return (decode str) 55 | 56 | send2 :: Serialize a => Connection -> (a, a) -> IO () 57 | send2 conn (x,y) = mapM_ (send conn) [x,y] 58 | 59 | recv2 :: Serialize a => Connection -> IO (a, a) 60 | recv2 conn = do 61 | [x,y] <- replicateM 2 (recv conn) 62 | return (x,y) 63 | 64 | send4 :: Serialize a => Connection -> (a, a, a, a) -> IO () 65 | send4 conn (w,x,y,z) = mapM_ (send conn) [w,x,y,z] 66 | 67 | recv4 :: Serialize a => Connection -> IO (a, a, a, a) 68 | recv4 conn = do 69 | [w,x,y,z] <- replicateM 4 (recv conn) 70 | return (w,x,y,z) 71 | 72 | connectTo :: HostName -> Port -> (Handle -> IO a) -> IO a 73 | connectTo host port_ f = withSocketsDo $ do 74 | let port = toEnum port_ 75 | sock <- socket AF_INET Stream 0 76 | addrs <- liftM hostAddresses $ getHostByName host 77 | when (null addrs) $ err "connectTo" ("no such host: " ++ host) 78 | connect sock $ SockAddrInet port (head addrs) 79 | perform sock f 80 | 81 | listenAt :: Port -> (Handle -> IO a) -> IO a 82 | listenAt port_ f = withSocketsDo $ do 83 | let port = toEnum port_ 84 | lsock <- socket AF_INET Stream 0 85 | bind lsock (SockAddrInet port iNADDR_ANY) 86 | listen lsock sOMAXCONN 87 | (sock,SockAddrInet _ _) <- accept lsock 88 | perform sock f 89 | 90 | perform :: Socket -> (Handle -> IO a) -> IO a 91 | perform sock f = withSocketsDo $ do 92 | handle <- socketToHandle sock ReadWriteMode 93 | result <- f handle 94 | hClose handle 95 | return result 96 | 97 | printConnectionInfo :: Connection -> IO () 98 | printConnectionInfo c = do 99 | sent <- readIORef (conn_bytes_sent c) 100 | recvd <- readIORef (conn_bytes_received c) 101 | printf "[garblerProto] %d bytes sent, %d bytes received.\n" sent recvd 102 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/ObliviousTransfer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | module Crypto.GarbledCircuits.ObliviousTransfer where 4 | 5 | import Crypto.GarbledCircuits.Network 6 | import Crypto.GarbledCircuits.Types 7 | import Crypto.GarbledCircuits.Util 8 | import Crypto.GarbledCircuits.Encryption hiding (randBool) 9 | 10 | import Crypto.Cipher.AES128 (AESKey128) 11 | import Crypto.Number.Prime 12 | import Crypto.Number.Generate 13 | import Crypto.Number.ModArithmetic 14 | import Crypto.Number.Serialize 15 | import "crypto-random" Crypto.Random 16 | 17 | import Control.Applicative 18 | import Control.Monad.State 19 | import Control.Monad.Reader 20 | import Data.Maybe 21 | import Data.Bits 22 | import Data.Word 23 | import Data.Serialize hiding (get, put) 24 | import Data.List.Split (chunksOf) 25 | import qualified Data.ByteString as BS 26 | 27 | -- diffie-hellman based dual mode oblivious transfer from https://eprint.iacr.org/2007/348 28 | -- WARNING: this is a work in progress. 29 | 30 | keySize = 3072 31 | 32 | type SecretKey = Integer 33 | type Plaintext = Integer 34 | type Ciphertext = (Integer, Integer) 35 | type CRS = (Integer, Integer, Integer, Integer) 36 | type OTPublicKey = (Integer, Integer) 37 | 38 | type OT = ReaderT Integer (StateT SystemRNG IO) 39 | 40 | runOT :: Int -> OT a -> IO a 41 | runOT n m = do 42 | gen <- cprgCreate <$> createEntropyPool 43 | let (p, gen') = generatePrime gen n 44 | evalStateT (runReaderT m p) gen' 45 | 46 | -------------------------------------------------------------------------------- 47 | -- ot extension 48 | -- https://web.engr.oregonstate.edu/~rosulekm/scbib/index.php?n=Paper.IKNP03 49 | 50 | k = 1 -- number of OTs 51 | 52 | xorBits :: [Bool] -> [Bool] -> [Bool] 53 | xorBits xs ys | length xs /= length ys = err "xorBits" "unequal length arguments" 54 | | otherwise = zipWith xor xs ys 55 | 56 | otSend :: Connection -> AESKey128 -> [(ByteString, ByteString)] -> IO () 57 | otSend conn key elems = do 58 | let n = length elems 59 | g0 <- newGen 60 | let (s, g1) = randBits k g0 61 | q <- forM s $ \b -> do 62 | qi <- recvOT conn b 63 | return $ bytes2Bits n qi 64 | let rows = tr q 65 | forM_ (zip3 [0..] rows elems) $ \(i, row, (x,y)) -> do 66 | let r = lpad 16 (bits2Bytes row) 67 | rs = lpad 16 (bits2Bytes (xorBits row s)) 68 | let ctx = x `xorBytes` hash key r i 69 | let cty = y `xorBytes` hash key rs i 70 | send2 conn (ctx, cty) 71 | 72 | otRecv :: Connection -> AESKey128 -> [Bool] -> IO [ByteString] 73 | otRecv conn key choices = do 74 | let n = length choices 75 | r = bits2Bytes choices 76 | g0 <- newGen 77 | let (t, g1) = randBitMatrix (n, k) g0 78 | forM (tr t) $ \col -> do 79 | let j = bits2Bytes col 80 | sendOT conn (lpad 16 j, lpad 16 j `xorBytes` lpad 16 r) 81 | forM (zip3 [0..] choices t) $ \(i, b, row) -> do 82 | (x,y) <- recv2 conn 83 | let c = if b then y else x 84 | let m = c `xorBytes` hash key (lpad 16 (bits2Bytes row)) i 85 | return m 86 | 87 | randBytes :: Int -> SystemRNG -> (ByteString, SystemRNG) 88 | randBytes = cprgGenerate 89 | 90 | randBits :: Int -> SystemRNG -> ([Bool], SystemRNG) 91 | randBits n g = (fmap fst bits, snd (last bits)) 92 | where 93 | bits = take n $ tail $ iterate (\(_, g) -> randBool g) (False, g) 94 | 95 | randBitMatrix :: (Int, Int) -> SystemRNG -> ([[Bool]], SystemRNG) 96 | randBitMatrix (height, width) g0 = (chunksOf width bits, g1) 97 | where 98 | (bits, g1) = randBits (height * width) g0 99 | 100 | randBool :: SystemRNG -> (Bool, SystemRNG) 101 | randBool g0 = ((byte .&. 1) > 0, g1) 102 | where 103 | (b, g1) = cprgGenerate 1 g0 104 | byte = BS.head b 105 | 106 | -------------------------------------------------------------------------------- 107 | -- dual mode ot 108 | -- TODO find a more implementable OT 109 | 110 | -- only intended to share 128 bit secrets 111 | sendOT :: Connection -> (ByteString, ByteString) -> IO () 112 | sendOT conn (x,y) = sendDual conn (os2ip x, os2ip y) 113 | 114 | -- only intended to share 128 bit secrets 115 | recvOT :: Connection -> Bool -> IO ByteString 116 | recvOT conn sigma = fromJust <$> i2ospOf 16 <$> recvDual conn sigma 117 | 118 | recvDual :: Connection -> Bool -> IO Plaintext 119 | recvDual conn sigma = do 120 | gen <- newGen 121 | let (p, gen') = generatePrime gen keySize 122 | send conn p 123 | flip evalStateT gen' $ flip runReaderT p $ do 124 | crs <- setupMessy 125 | (pk, sk) <- keyGen crs sigma 126 | liftIO $ send4 conn crs 127 | liftIO $ send2 conn pk 128 | c0 <- liftIO $ recv2 conn 129 | c1 <- liftIO $ recv2 conn 130 | if sigma then dec sk c1 else dec sk c0 131 | 132 | sendDual :: Connection -> (Plaintext, Plaintext) -> IO () 133 | sendDual conn elems = do 134 | p <- recv conn 135 | when (fst elems > p) $ err "sendDual" "arg0 greater than p" 136 | when (snd elems > p) $ err "sendDual" "arg1 greater than p" 137 | gen <- newGen 138 | flip evalStateT gen $ flip runReaderT p $ do 139 | crs <- liftIO $ recv4 conn 140 | pk <- liftIO $ recv2 conn 141 | (c0,c1) <- enc crs pk elems 142 | liftIO $ send2 conn c0 143 | liftIO $ send2 conn c1 144 | 145 | setupMessy :: OT CRS 146 | setupMessy = do 147 | g0 <- randGenerator 148 | g1 <- randGenerator 149 | (x0,x1) <- randZpDistinct 150 | h0 <- modExp g0 x0 151 | h1 <- modExp g1 x1 152 | return (g0,h0,g1,h1) 153 | 154 | setupDec :: OT CRS 155 | setupDec = do 156 | g0 <- randGenerator 157 | y <- randZp 158 | g1 <- modExp g0 y 159 | x <- randZp 160 | h0 <- modExp g0 x 161 | h1 <- modExp g1 x 162 | return (g0,h0,g1,h1) 163 | 164 | keyGen :: CRS -> Bool -> OT (OTPublicKey, SecretKey) 165 | keyGen (g0,h0,g1,h1) b = do 166 | let (g',h') = if b then (g1,h1) else (g0,h0) 167 | r <- randZp 168 | g <- modExp g' r 169 | h <- modExp h' r 170 | return ((g,h), r) 171 | 172 | enc :: CRS -> OTPublicKey -> (Plaintext, Plaintext) -> OT (Ciphertext, Ciphertext) 173 | enc (g0,h0,g1,h1) (g,h) (m0,m1) = do 174 | let pk0 = (g0, h0, g, h) 175 | pk1 = (g1, h1, g, h) 176 | c0 <- ddhEnc pk0 m0 177 | c1 <- ddhEnc pk1 m1 178 | return (c0,c1) 179 | 180 | dec :: SecretKey -> Ciphertext -> OT Plaintext 181 | dec = ddhDec 182 | 183 | -------------------------------------------------------------------------------- 184 | -- modified diffie hellman 185 | 186 | type DHPublicKey = (Integer, Integer, Integer, Integer) 187 | 188 | ddhKeyGen :: OT (DHPublicKey, SecretKey) 189 | ddhKeyGen = do 190 | g <- randGenerator 191 | h <- randGenerator 192 | x <- randZp 193 | g' <- modExp g x 194 | h' <- modExp h x 195 | let pk = (g, h, g', h') 196 | return (pk, x) 197 | 198 | ddhEnc :: DHPublicKey -> Plaintext -> OT Ciphertext 199 | ddhEnc pk m = do 200 | (u,v) <- randomize pk 201 | res <- modMult v m 202 | return (u, res) 203 | 204 | randomize :: DHPublicKey -> OT (Integer, Integer) 205 | randomize (g,h,g',h') = do 206 | s <- randZp 207 | t <- randZp 208 | u <- bind2 modMult (modExp g s) (modExp h t) 209 | v <- bind2 modMult (modExp g' s) (modExp h' t) 210 | return (u,v) 211 | 212 | ddhDec :: SecretKey -> Ciphertext -> OT Plaintext 213 | ddhDec sk (c0, c1) = do 214 | p <- ask 215 | modMult c1 =<< (inverseCoprimes <$> modExp c0 sk <*> pure p) 216 | 217 | -------------------------------------------------------------------------------- 218 | -- helpers 219 | 220 | tr :: [[a]] -> [[a]] 221 | tr xs | null xs = [] 222 | | null (head xs) = [] 223 | | otherwise = fmap head xs : tr (fmap tail xs) 224 | 225 | newGen :: IO SystemRNG 226 | newGen = cprgCreate <$> createEntropyPool 227 | 228 | bits2Bytes :: [Bool] -> ByteString 229 | bits2Bytes = BS.pack . fmap bits2Word . chunksOf 8 230 | 231 | bytes2Bits :: Int -> ByteString -> [Bool] 232 | bytes2Bits n = take n . concatMap word2Bits . BS.unpack 233 | 234 | -------------------------------------------------------------------------------- 235 | -- OT monad helpers 236 | 237 | -- | Modular exponentiation using the prime p which is created in 'ddhKeyGen' 238 | modExp :: Integer -> Integer -> OT Integer 239 | modExp g x = expFast g x <$> ask 240 | 241 | -- | Modular multiplication using the prime p which is created in 'ddhKeyGen'. 242 | modMult :: Integer -> Integer -> OT Integer 243 | modMult x y = mod (x * y) <$> ask 244 | 245 | randGenerator :: OT Integer 246 | randGenerator = randRange 2 247 | 248 | randZp :: OT Integer 249 | randZp = randRange 1 250 | 251 | randZpDistinct :: OT (Integer, Integer) 252 | randZpDistinct = do 253 | x <- randZp 254 | y <- randZp 255 | if x == y then 256 | randZpDistinct 257 | else 258 | return (x,y) 259 | 260 | -- | Get a random integer in the range (low, p-1) in the 'OT' monad 261 | randRange :: Integer -> OT Integer 262 | randRange low = do 263 | p <- ask 264 | rand (\gen -> generateBetween gen low p) 265 | 266 | -- | Do the RNG bookkeeping on a function taking and producing one. 267 | rand :: (SystemRNG -> (a, SystemRNG)) -> OT a 268 | rand f = do 269 | g <- get 270 | let (a, g') = f g 271 | put g' 272 | return a 273 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/TruthTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module Crypto.GarbledCircuits.TruthTable 4 | ( circ2tt 5 | , circ2tt' 6 | , evalTT 7 | ) 8 | where 9 | 10 | import Crypto.GarbledCircuits.Types 11 | import Crypto.GarbledCircuits.Util 12 | 13 | import qualified Data.Set as S 14 | import qualified Data.Map as M 15 | import Data.Maybe 16 | import Control.Monad.State 17 | import Data.Bits (xor) 18 | import Data.Functor 19 | 20 | -------------------------------------------------------------------------------- 21 | -- transform circ to tt 22 | 23 | -- NotBinary gets passed around as we transform a Circuit to a TruthTable. 24 | data NotBinary = UNot (Ref TruthTable) 25 | | UConst Bool 26 | deriving (Eq, Ord, Show) 27 | 28 | circ2tt :: Program Circuit -> Program TruthTable 29 | circ2tt = fromJust . circ2tt' 30 | 31 | circ2tt' :: Program Circuit -> Maybe (Program TruthTable) 32 | circ2tt' prog_circ = if success then Just prog_tt else Nothing 33 | where 34 | (success, prog_tt) = runState (transform $ prog_output prog_circ) emptyProg 35 | 36 | transform :: [Ref Circuit] -> State (Program TruthTable) Bool 37 | transform outs = do 38 | eitherOuts <- mapM trans outs 39 | case mapM check eitherOuts of 40 | Nothing -> return False 41 | Just outs' -> do 42 | modify (\p -> p { prog_output = outs' }) 43 | return True 44 | where 45 | check (Right ref) = Just ref 46 | check (Left _) = Nothing 47 | 48 | --return a circ if it is a unary gate in order to fold it into its parent 49 | trans :: Ref Circuit -> State (Program TruthTable) (Either NotBinary (Ref TruthTable)) 50 | trans ref = do 51 | let circ = lookupC ref prog_circ 52 | cs <- mapM trans (children circ) 53 | if boolean circ then do 54 | let [x,y] = cs 55 | mkBin (circ2op circ) x y 56 | else case circ of 57 | Not _ -> return $ mkNot (head cs) 58 | Const b -> return $ Left (UConst b) 59 | Input i p -> Right <$> inputp p (TTInp i p) 60 | x -> error ("[trans] unrecognized pattern: " ++ show x) 61 | 62 | -------------------------------------------------------------------------------- 63 | -- combine elements - this is the meat of the TruthTable translator 64 | 65 | mkBin :: Operation 66 | -> Either NotBinary (Ref TruthTable) 67 | -> Either NotBinary (Ref TruthTable) 68 | -> State (Program TruthTable) (Either NotBinary (Ref TruthTable)) 69 | 70 | mkBin op (Right x) (Right y) = Right <$> internp (create op x y) 71 | mkBin op x (Left (UConst b)) = return $ foldConst op b x 72 | mkBin op (Left (UConst b)) y = return $ foldConst op b y 73 | 74 | mkBin op (Right x) (Left (UNot y)) = Right <$> internp (create op x y) { tt_negy = True } 75 | mkBin op (Left (UNot x)) (Right y) = Right <$> internp (create op x y) { tt_negx = True } 76 | mkBin op (Left (UNot x)) (Left (UNot y)) = Right <$> internp (create op x y) { tt_negx = True, tt_negy = True } 77 | 78 | mkNot :: Either NotBinary (Ref TruthTable) -> Either NotBinary (Ref TruthTable) 79 | mkNot (Right x) = Left (UNot x) 80 | mkNot (Left (UNot x)) = Right x 81 | mkNot (Left (UConst b)) = Left (UConst (not b)) 82 | 83 | create :: Operation -> Ref TruthTable -> Ref TruthTable -> TruthTable 84 | create op x y = TT { tt_f = op 85 | , tt_inpx = x 86 | , tt_inpy = y 87 | , tt_negx = False 88 | , tt_negy = False 89 | } 90 | 91 | foldConst :: Operation -> Bool -> Either NotBinary (Ref TruthTable) 92 | -> Either NotBinary (Ref TruthTable) 93 | foldConst XOR True x = mkNot x 94 | foldConst XOR False x = x 95 | foldConst AND True x = x 96 | foldConst AND False _ = Left (UConst False) 97 | foldConst OR False x = x 98 | foldConst OR True _ = Left (UConst True) 99 | foldConst _ _ _ = err "foldConst" "unrecognized operation" 100 | 101 | -------------------------------------------------------------------------------- 102 | -- truth table evaluator 103 | 104 | evalTT :: [Bool] -> [Bool] -> Program TruthTable -> [Bool] 105 | evalTT inpGb inpEv prog = evalProg construct prog 106 | where 107 | inputs Garbler = M.fromList (zip (sortedInput readTTInput Garbler prog) inpGb) 108 | inputs Evaluator = M.fromList (zip (sortedInput readTTInput Evaluator prog) inpEv) 109 | 110 | construct :: Ref TruthTable -> TruthTable -> [Bool] -> Bool 111 | construct ref (TTInp i p) [] = case M.lookup ref (inputs p) of 112 | Just b -> b 113 | Nothing -> err "construct" ("no input with id: " ++ show i) 114 | construct _ (TT {tt_f, tt_negx, tt_negy}) [x,y] = 115 | let x' = if tt_negx then not x else x 116 | y' = if tt_negy then not y else y 117 | in eval tt_f x' y' 118 | construct _ _ _ = err "construct" "bad pattern" 119 | 120 | eval XOR = xor 121 | eval AND = (&&) 122 | eval OR = (||) 123 | eval op = err "evalTT" ("unknown binary gate: " ++ show op) 124 | 125 | -------------------------------------------------------------------------------- 126 | -- helper functions 127 | 128 | boolean :: Circuit -> Bool 129 | boolean (Xor _ _) = True 130 | boolean (And _ _) = True 131 | boolean (Or _ _) = True 132 | boolean _ = False 133 | 134 | circ2op :: Circuit -> Operation 135 | circ2op (Input _ _) = INPUT 136 | circ2op (Const _) = CONST 137 | circ2op (Not _) = NOT 138 | circ2op (Xor _ _) = XOR 139 | circ2op (And _ _) = AND 140 | circ2op (Or _ _) = OR 141 | 142 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} 2 | 3 | module Crypto.GarbledCircuits.Types where 4 | 5 | import Control.Monad.Reader 6 | import Control.Monad.State (StateT) 7 | import Crypto.Cipher.AES128 8 | import qualified Data.ByteString as BS 9 | import qualified Data.Map as M 10 | import qualified Data.Set as S 11 | import Data.IORef 12 | 13 | type Map = M.Map 14 | type Set = S.Set 15 | type ByteString = BS.ByteString 16 | 17 | -- |'Ref' is a way to associate ids with some kind of gate. Generally, we think 18 | -- of a Ref as representing the output of the gate. 19 | newtype Ref a = Ref { unRef :: Int } deriving (Enum, Ord, Eq) 20 | 21 | -- |A garbled circuit is an asymmetric two-party protocol. The 'Garbler' creates 22 | -- wirelabels for each gate, and sends them to the 'Evaluator'. The 'Evaluator' 23 | -- decrypts the circuit and reports the output. 24 | data Party = Garbler | Evaluator deriving (Enum, Ord, Eq, Show) 25 | 26 | newtype InputId = InputId { getInputId :: Int } deriving (Enum, Ord, Eq) 27 | 28 | -- |A 'Circuit' is the fundamental description of the program that is executed 29 | -- in a garbled circuit. 30 | -- 31 | -- Use the constructors in "Crypto.GarbledCircuits.Language" to create your own 32 | -- circuits. 33 | data Circuit = Input InputId Party 34 | | Const Bool 35 | | Not (Ref Circuit) 36 | | Xor (Ref Circuit) (Ref Circuit) 37 | | And (Ref Circuit) (Ref Circuit) 38 | | Or (Ref Circuit) (Ref Circuit) 39 | deriving (Eq, Ord, Show) 40 | 41 | -- it is convenient to have a Circuit without associated data 42 | data Operation = INPUT 43 | | CONST 44 | | NOT 45 | | XOR 46 | | AND 47 | | OR 48 | deriving (Show, Eq, Ord) 49 | 50 | type Env c = Map (Ref c) c 51 | 52 | -- |'Program' keeps track of inputs, outputs, and references. 53 | -- 54 | -- It is polymorphic over 'Circuit', 'TruthTable', and 'GarbledGate'. 55 | data Program c = Program { 56 | -- | Input bits belonging to the 'Garbler' 57 | prog_input_gb :: Set (Ref c) 58 | -- | Input bits belonging to the 'Evaluator' 59 | , prog_input_ev :: Set (Ref c) 60 | -- | The output bits, in order. 61 | , prog_output :: [Ref c] 62 | -- | A mapping of Refs to 'c' 63 | , prog_env :: Env c 64 | } deriving (Show, Eq) 65 | 66 | -- |'TruthTable' is a plaintext representation of a 'Circuit' where all gates 67 | -- are binary. To make it we must fold 'Const' and 'Not' gates into the binary 68 | -- ('Xor', 'And', 'Or') gates above them. This is necessary because only binary 69 | -- gates are garbleable in our scheme. 70 | data TruthTable = TTInp InputId Party 71 | | TT { 72 | -- | The type of this gate. 73 | tt_f :: Operation 74 | -- | A ref to the left input gate. 75 | , tt_inpx :: Ref TruthTable 76 | -- | A ref to the right input gate. 77 | , tt_inpy :: Ref TruthTable 78 | -- | Whether the left input should be negated. 79 | , tt_negx :: Bool 80 | -- | Whether the right input should be negated. 81 | , tt_negy :: Bool 82 | } deriving (Ord, Eq, Show) 83 | 84 | -------------------------------------------------------------------------------- 85 | -- data types for garbling 86 | 87 | -- | 'Wirelabel' is simply 16 byte long 'ByteString' (128 bits). 88 | type Wirelabel = BS.ByteString 89 | 90 | -- | 'WirelabelPair' is a mapping of 'Wirelabel's to 'True' and 'False' 91 | data WirelabelPair = WirelabelPair { wlp_false :: Wirelabel 92 | , wlp_true :: Wirelabel 93 | } deriving (Show) 94 | 95 | -- |A 'GarbledGate' is either an input, a free xor, or a half gate. 96 | -- 97 | -- Inputs are placeholders in 'GarbledGate'. At garbletime, two random 128-bit strings called 98 | -- 'Wirelabel's are chosen for each input bit. One 'Wirelabel' corresponds to 'True' and the 99 | -- other to 'False'. The 'Garbler' knows the truth-values for all 'Wirelabel's. The 'Evaluator' 100 | -- learns the 'Wirelabel's for each of its inputs, but cannot guess what the other wirelabels 101 | -- are since they are 128-bit random strings. 102 | -- 103 | -- 'Xor' gates are free in the sense that they require no communication. The evaluator simply 104 | -- xors its input wires to get the correct result. See 105 | -- for details. 106 | -- 107 | -- 'And' and 'Or' gates map to 'HalfGates'. Half gates contain the only information in a garbled 108 | -- circuit that the 'Garbler' needs to send to the 'Evaluator'. Namely, two 'Wirelabels' per 109 | -- gate. Half gates are a very recent innovation. See ZRE15 110 | -- for details. 111 | data GarbledGate = GarbledInput InputId Party 112 | | FreeXor (Ref GarbledGate) (Ref GarbledGate) 113 | | HalfGate (Ref GarbledGate) (Ref GarbledGate) Wirelabel Wirelabel 114 | deriving (Show, Eq, Ord) 115 | 116 | -- |A monad for creating garbled circuits. 117 | type Garble = StateT (Program GarbledGate) 118 | (ReaderT (Program TruthTable) 119 | (StateT Context 120 | IO)) 121 | 122 | -- |'Context' contains state and proprietary information for garbling. 123 | data Context = Context { 124 | -- | The output wires for each gate. 125 | ctx_pairs :: Map (Ref GarbledGate) WirelabelPair 126 | -- | The truth value of each wire. 127 | , ctx_truth :: Map Wirelabel Bool 128 | -- | The AES key for the hash function. 129 | , ctx_key :: AESKey128 130 | -- | The @R@ value. Necessary for free-xor and half-gates. 131 | , ctx_r :: Wirelabel 132 | -- | The @ctr@ value. Used in half-gates. 133 | , ctx_ctr :: Int 134 | } 135 | 136 | -------------------------------------------------------------------------------- 137 | -- network 138 | 139 | type Port = Int 140 | 141 | data Connection = Connection { conn_send :: ByteString -> IO () 142 | , conn_recv :: Int -> IO ByteString 143 | , conn_bytes_sent :: IORef Int 144 | , conn_bytes_received :: IORef Int 145 | } 146 | 147 | -------------------------------------------------------------------------------- 148 | -- instances 149 | 150 | -- | 'CanHaveChildren' allows us to write polymorphic traversal functions. 151 | class CanHaveChildren c where 152 | children :: c -> [Ref c] 153 | 154 | instance CanHaveChildren Circuit where 155 | children (Not x ) = [x] 156 | children (Xor x y) = [x,y] 157 | children (And x y) = [x,y] 158 | children (Or x y) = [x,y] 159 | children _ = [] 160 | 161 | instance CanHaveChildren TruthTable where 162 | children (TT {tt_inpx = x, tt_inpy = y}) = [x,y] 163 | children (TTInp _ _) = [] 164 | 165 | instance CanHaveChildren GarbledGate where 166 | children (GarbledInput _ _) = [] 167 | children (FreeXor x y) = [x,y] 168 | children (HalfGate x y _ _) = [x,y] 169 | 170 | instance Show (Ref c) where 171 | show (Ref x) = "<" ++ show x ++ ">" 172 | 173 | instance Show InputId where 174 | show (InputId i) = "in" ++ show i 175 | 176 | -------------------------------------------------------------------------------- 177 | -- helpers 178 | 179 | -- | Helper for choosing 'Program' input accessors. 180 | prog_inputs :: Party -> Program c -> Set (Ref c) 181 | prog_inputs Garbler = prog_input_gb 182 | prog_inputs Evaluator = prog_input_ev 183 | 184 | -- | A 'Wirelabel' that contains only zeroes. 185 | zeroWirelabel :: Wirelabel 186 | zeroWirelabel = BS.replicate 16 0 187 | 188 | emptyEnv :: Env c 189 | emptyEnv = M.empty 190 | 191 | emptyContext :: Context 192 | emptyContext = Context M.empty M.empty undefined undefined 0 193 | 194 | emptyProg :: Program c 195 | emptyProg = Program { prog_input_gb = S.empty 196 | , prog_input_ev = S.empty 197 | , prog_output = [] 198 | , prog_env = emptyEnv 199 | } 200 | -------------------------------------------------------------------------------- /src/Crypto/GarbledCircuits/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, ScopedTypeVariables, FlexibleContexts #-} 2 | 3 | module Crypto.GarbledCircuits.Util 4 | ( bind2 5 | , bits2Word 6 | , word2Bits 7 | , evalProg 8 | , progSize 9 | , ungarble 10 | , showWirelabel 11 | , inputSize 12 | , inputPairs 13 | , inputWires 14 | , nextRef 15 | , inputp 16 | , internp 17 | , writep 18 | , lookupC 19 | , lsb 20 | , readGGInput 21 | , readTTInput 22 | , sel 23 | , sortedInput 24 | , orBytes 25 | , xorBytes 26 | , xorWords 27 | , mask 28 | , err 29 | , (!!!) 30 | , trace 31 | , traceM 32 | ) 33 | where 34 | 35 | import Crypto.GarbledCircuits.Types 36 | 37 | import Control.Monad.State 38 | import Data.Bits hiding (xor) 39 | import qualified Data.Bits 40 | import qualified Data.ByteString as BS 41 | import qualified Data.Map as M 42 | import Data.Maybe (fromMaybe) 43 | import qualified Data.Set as S 44 | import Data.Tuple 45 | import Data.Word 46 | import Data.Ord (comparing) 47 | import Data.List 48 | import Numeric (showHex) 49 | import Prelude hiding (traverse) 50 | 51 | #ifdef DEBUG 52 | import Debug.Trace 53 | #else 54 | trace :: String -> a -> a 55 | trace = flip const 56 | 57 | traceM :: Monad m => String -> m () 58 | traceM _ = return () 59 | #endif 60 | 61 | -------------------------------------------------------------------------------- 62 | -- general helper functions 63 | 64 | bind2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c 65 | bind2 f a b = do x <- a; y <- b; f x y 66 | 67 | -- returns a little-endian list of bits 68 | word2Bits :: (FiniteBits b, Num b, Ord b, Bits b) => b -> [Bool] 69 | word2Bits x = map (bitAnd x) (take (finiteBitSize x) pow2s) 70 | where 71 | bitAnd a b = a .&. b > 0 72 | 73 | -- takes a little-endian list of bits 74 | bits2Word :: (Bits a, Num a) => [Bool] -> a 75 | bits2Word bs = sum $ zipWith select bs pow2s 76 | where 77 | select b x = if b then x else 0 78 | 79 | pow2s :: (Num b, Bits b) => [b] 80 | pow2s = [ shift 1 x | x <- [0..] ] 81 | 82 | xorBytes :: ByteString -> ByteString -> ByteString 83 | xorBytes x y | BS.length x /= BS.length y = err "xor" "unequal length inputs" 84 | | otherwise = BS.pack $ BS.zipWith Data.Bits.xor x y 85 | 86 | orBytes :: ByteString -> ByteString -> ByteString 87 | orBytes x y | BS.length x /= BS.length y = err "or" "unequal length inputs" 88 | | otherwise = BS.pack $ BS.zipWith (.|.) x y 89 | 90 | xorWords :: [Word8] -> [Word8] -> [Word8] 91 | xorWords = zipWith Data.Bits.xor 92 | 93 | progSize :: Program c -> Int 94 | progSize = M.size . prog_env 95 | 96 | inputSize :: Party -> Program c -> Int 97 | inputSize p prog = S.size (prog_inputs p prog) 98 | 99 | -------------------------------------------------------------------------------- 100 | -- garbled gate helpers 101 | 102 | lsb :: Wirelabel -> Bool 103 | lsb wl = BS.last wl .&. 1 > 0 104 | 105 | sel :: Bool -> WirelabelPair -> Wirelabel 106 | sel b = if b then wlp_true else wlp_false 107 | 108 | mask :: Bool -> Wirelabel -> Wirelabel 109 | mask b wl = if b then wl else zeroWirelabel 110 | 111 | inputPairs :: Party -> Program GarbledGate -> Context -> [WirelabelPair] 112 | inputPairs p prog ctx = map (ctx_pairs ctx !!!) (sortedInput readGGInput p prog) 113 | 114 | inputWires :: Party -> Program GarbledGate -> Context -> [Bool] -> [Wirelabel] 115 | inputWires party prog ctx inp = zipWith sel inp (inputPairs party prog ctx) 116 | 117 | ungarble :: Context -> Wirelabel -> Bool 118 | ungarble ctx wl = case M.lookup wl (ctx_truth ctx) of 119 | Nothing -> err "ungarble" $ "unknown wirelabel: " ++ showWirelabel wl 120 | Just b -> b 121 | 122 | showWirelabel :: Wirelabel -> String 123 | showWirelabel wl = "wl" ++ showCol (lsb wl) ++ " " ++ hexStr 124 | where showCol b = if b then "1" else "0" 125 | hexStr = concatMap (pad . hex) $ BS.unpack wl 126 | pad s = if length s == 1 then '0' : s else s 127 | hex = flip showHex "" 128 | 129 | -------------------------------------------------------------------------------- 130 | -- polymorphic helper functions for State monads over a Program 131 | 132 | nextRef :: (Ord c, MonadState (Program c) m) => m (Ref c) 133 | nextRef = do 134 | env <- gets prog_env 135 | return $ succ (fst (M.findMax env)) 136 | 137 | internp :: (Ord c, MonadState (Program c) m) => c -> m (Ref c) 138 | internp circ = do 139 | prog <- get 140 | let env = prog_env prog 141 | dedup = map swap (M.toList env) 142 | case lookup circ dedup of 143 | Just ref -> return ref 144 | Nothing -> do 145 | let ref = if M.null env then Ref 0 else succ $ fst (M.findMax env) 146 | env' = M.insert ref circ env 147 | put prog { prog_env = env' } 148 | return ref 149 | 150 | inputp :: (Ord c, MonadState (Program c) m) => Party -> c -> m (Ref c) 151 | inputp party inp = do 152 | ref <- internp inp 153 | modify $ \p -> case party of 154 | Garbler -> p { prog_input_gb = S.insert ref (prog_input_gb p) } 155 | Evaluator -> p { prog_input_ev = S.insert ref (prog_input_ev p) } 156 | return ref 157 | 158 | writep :: (Ord c, MonadState (Program c) m) => Ref c -> c -> m () 159 | writep ref circ = modify (\p -> p { prog_env = M.insert ref circ (prog_env p) }) 160 | 161 | lookupC :: Ref c -> Program c -> c 162 | lookupC ref prog = fromMaybe (error "[lookupC] no c") (M.lookup ref (prog_env prog)) 163 | 164 | readTTInput :: TruthTable -> InputId 165 | readTTInput (TTInp i p) = i 166 | readTTInput _ = undefined 167 | 168 | readGGInput :: GarbledGate -> InputId 169 | readGGInput (GarbledInput i p) = i 170 | readGGInput _ = undefined 171 | 172 | -- Program c -> [Ref c] -> [(Ref c, c)] -> Sorted [(Ref c, c)] -> [Ref c] 173 | sortedInput :: (c -> InputId) -> Party -> Program c -> [Ref c] 174 | sortedInput readInputId party prog = fst <$> sortBy byInputId inputs 175 | where 176 | -- [Ref c] 177 | inputRefs = S.toList $ prog_inputs party prog 178 | -- Program c -> Ref c -> (Ref c, c) 179 | findC prog ref = (ref, lookupC ref prog) 180 | -- [(Ref c, c)] 181 | inputs = findC prog <$> inputRefs 182 | -- (Ref c, c) -> Int 183 | inputIdField = getInputId . readInputId . snd 184 | -- ((Ref c, c) -> (Ref c, c) -> Ordering) 185 | byInputId = comparing inputIdField 186 | 187 | -------------------------------------------------------------------------------- 188 | -- polymorphic evaluation 189 | 190 | evalProg :: (Show b, CanHaveChildren c) 191 | => (Ref c -> c -> [b] -> b) -> Program c -> [b] 192 | evalProg construct prog = outputs 193 | where 194 | resultMap = execState (traverse construct prog) M.empty 195 | outputs = map (resultMap !!!) (prog_output prog) 196 | 197 | traverse :: (Show b, MonadState (Map (Ref c) b) m, CanHaveChildren c) 198 | => (Ref c -> c -> [b] -> b) -> Program c -> m () 199 | traverse construct prog = mapM_ eval (M.keys (prog_env prog)) 200 | where 201 | getVal ref = get >>= \precomputed -> 202 | case M.lookup ref precomputed of 203 | Nothing -> err "traverse.getVal" ("unknown ref: " ++ show ref) 204 | Just res -> return res 205 | eval ref = do 206 | let c = lookupC ref prog 207 | kids <- mapM getVal (children c) 208 | let result = construct ref c kids 209 | modify (M.insert ref result) 210 | return result 211 | 212 | -------------------------------------------------------------------------------- 213 | -- evil helpers 214 | 215 | err :: String -> String -> a 216 | err name warning = error $ "[" ++ name ++ "] " ++ warning 217 | 218 | (!!!) :: (Show k, Show v, Ord k) => Map k v -> k -> v 219 | m !!! k = case M.lookup k m of 220 | Nothing -> err "!!!" ("OOPS: " ++ show m) 221 | Just v -> v 222 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import TestGarbledCircuits 4 | import TestObliviousTransfer 5 | 6 | import Data.Monoid 7 | import Test.Framework 8 | import Test.QuickCheck 9 | 10 | main :: IO () 11 | main = defaultMainWithOpts tests mempty { ropt_color_mode = Just ColorAlways } 12 | 13 | tests = [] 14 | ++ garbledCircuitTests 15 | ++ obliviousTransferTests 16 | -------------------------------------------------------------------------------- /test/TestGarbledCircuits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module TestGarbledCircuits where 5 | 6 | import Control.Concurrent 7 | import Data.Functor 8 | import Data.Maybe 9 | import Data.Serialize 10 | 11 | import Test.Framework 12 | import Test.Framework.Providers.QuickCheck2 13 | import Test.QuickCheck 14 | import Test.QuickCheck.Monadic 15 | 16 | import Crypto.GarbledCircuits 17 | import qualified Crypto.GarbledCircuits.Language as L 18 | import Crypto.GarbledCircuits.GarbledGate 19 | import Crypto.GarbledCircuits.TruthTable 20 | import Crypto.GarbledCircuits.Encryption 21 | import Crypto.GarbledCircuits.Eval 22 | import Crypto.GarbledCircuits.Types 23 | import Crypto.GarbledCircuits.Util 24 | import Crypto.GarbledCircuits.Network 25 | 26 | garbledCircuitTests :: [Test] 27 | garbledCircuitTests = [ testProperty "The colors of new wirelabels are different" prop_colorsDifferent 28 | , testProperty "lsb R always equals 1" prop_lsbOfR 29 | , testProperty "Arbitrary circuit is correct" prop_arbitraryCircuitCorrect 30 | , testProperty "Reconstruct is correct" prop_reconstructCorrect 31 | , testProperty "Serialization is correct" prop_serializeCorrect 32 | , testProperty "Protocol works" prop_protoWorks 33 | ] 34 | 35 | prop_colorsDifferent :: Property 36 | prop_colorsDifferent = monadicIO $ do 37 | p <- testGarble newWirelabels 38 | assert $ lsb (wlp_true p) /= lsb (wlp_false p) 39 | 40 | prop_lsbOfR :: Property 41 | prop_lsbOfR = monadicIO (lsb <$> testGarble genR) 42 | 43 | prop_arbitraryCircuitCorrect :: Program Circuit -> Property 44 | prop_arbitraryCircuitCorrect circ = monadicIO $ do 45 | (_,gg,ctx) <- testCircuit circ 46 | inpA <- pick $ vector (inputSize Garbler circ) 47 | inpB <- pick $ vector (inputSize Evaluator circ) 48 | let pt = L.evalCircuit inpA inpB circ 49 | res = evalLocal inpA inpB (gg,ctx) 50 | assert (res == pt) 51 | 52 | ensureEither :: Eq b => Either a b -> b -> Bool 53 | ensureEither e eq = either (const False) (== eq) e 54 | 55 | prop_reconstructCorrect :: Program Circuit -> Property 56 | prop_reconstructCorrect circ = monadicIO $ do 57 | (tt, gg, _) <- testCircuit circ 58 | assert $ reconstruct tt (halfGates gg) == gg 59 | 60 | prop_serializeCorrect :: Program Circuit -> Property 61 | prop_serializeCorrect circ = monadicIO $ do 62 | (tt, gg, _) <- testCircuit circ 63 | assert $ ensureEither (reconstruct tt <$> decode (encode (halfGates gg))) gg 64 | 65 | prop_protoWorks :: Program Circuit -> Property 66 | prop_protoWorks prog = once $ monadicIO $ do 67 | inpA <- pick $ vector (inputSize Garbler prog) 68 | inpB <- pick $ vector (inputSize Evaluator prog) 69 | let pt = L.evalCircuit inpA inpB prog 70 | chan <- run newChan 71 | port <- pick $ choose (1024,65536) 72 | run $ forkIO $ do 73 | res <- listenAt port (garblerProto prog inpA . simpleConn) 74 | writeChan chan res 75 | ggEval <- run $ connectTo "localhost" port (evaluatorProto prog inpB . simpleConn) 76 | ggGarb <- run $ readChan chan 77 | assert (ggEval == pt && ggGarb == pt) 78 | 79 | -------------------------------------------------------------------------------- 80 | -- helpers 81 | 82 | testCircuit :: Program Circuit -> PropertyM IO (Program TruthTable, Program GarbledGate, Context) 83 | testCircuit circ = do 84 | let tt = circ2tt circ 85 | (gg, ctx) <- run (tt2gg tt) 86 | return (tt, gg, ctx) 87 | 88 | testGarble :: Garble a -> PropertyM IO a 89 | testGarble g = do 90 | ((x, _), _) <- run $ runGarble' emptyProg $ do 91 | updateKey =<< genKey 92 | updateR =<< genR 93 | g 94 | return x 95 | 96 | isGarblable :: Program Circuit -> Bool 97 | isGarblable = isJust . circ2tt' 98 | 99 | -------------------------------------------------------------------------------- 100 | -- instances 101 | 102 | instance Arbitrary Operation where 103 | arbitrary = elements [XOR, AND, OR, INPUT, NOT, CONST] 104 | 105 | instance Arbitrary (Program Circuit) where 106 | arbitrary = arbCircuit `suchThat` isGarblable 107 | 108 | arbCircuit :: Gen (Program Circuit) 109 | arbCircuit = do 110 | (x,_) <- mkCircuit =<< vector 20 111 | let x' = do ref <- x; return [ref] 112 | return (L.buildCircuit x') 113 | 114 | mkCircuit :: [Operation] -> Gen (L.Builder (Ref Circuit), [Operation]) 115 | mkCircuit (INPUT:ops) = do 116 | p <- elements [Garbler,Evaluator] 117 | return (L.input p, ops) 118 | 119 | mkCircuit (CONST:ops) = do 120 | b <- arbitrary 121 | return (L.const b, ops) 122 | 123 | mkCircuit (NOT:ops) = do 124 | (child, ops') <- mkCircuit ops 125 | return (L.not =<< child, ops') 126 | 127 | mkCircuit (op:ops) = do 128 | (x,ops') <- mkCircuit ops 129 | (y,ops'') <- mkCircuit ops' 130 | let c = bind2 (op2circ op) x y 131 | return (c, ops'') 132 | 133 | mkCircuit [] = do 134 | p <- elements [Garbler,Evaluator] 135 | return (L.input p, []) 136 | 137 | op2circ :: Operation -> Ref Circuit -> Ref Circuit -> L.Builder (Ref Circuit) 138 | op2circ XOR x y = L.xor x y 139 | op2circ AND x y = L.and x y 140 | op2circ OR x y = L.or x y 141 | op2circ _ _ _ = err "op2circ" "unsupported operation" 142 | -------------------------------------------------------------------------------- /test/TestObliviousTransfer.hs: -------------------------------------------------------------------------------- 1 | module TestObliviousTransfer where 2 | 3 | import Data.Word 4 | import Control.Concurrent 5 | import Data.Functor 6 | import Data.Maybe 7 | import Data.Monoid 8 | import Data.Serialize 9 | import Crypto.Number.Serialize 10 | import Crypto.Cipher.AES128 11 | import qualified Data.ByteString as BS 12 | 13 | import Test.Framework 14 | import Test.Framework.Providers.QuickCheck2 15 | import Test.QuickCheck 16 | import Test.QuickCheck.Monadic 17 | 18 | import Crypto.GarbledCircuits.ObliviousTransfer 19 | import Crypto.GarbledCircuits.Encryption 20 | import Crypto.GarbledCircuits.Network 21 | 22 | obliviousTransferTests :: [Test] 23 | obliviousTransferTests = [ 24 | testProperty "Diffie-Hellman is correct" prop_ddhCorrect 25 | , testProperty "Messy mode OT is correct" prop_messyModeCorrect 26 | , testProperty "Decryption mode OT is correct" prop_decModeCorrect 27 | , testProperty "Can convert from Integer to ByteString" prop_convWorks 28 | , testProperty "OT protocol works" prop_otProtoWorks 29 | , testProperty "OT extension works" prop_otExtWorks 30 | , testProperty "Bytes2Bits correct" prop_bytes2Bits 31 | , testProperty "Bits2Bytes w/ left padding correct" prop_bits2BytesLPad 32 | ] 33 | 34 | prop_ddhCorrect :: Property 35 | prop_ddhCorrect = once $ monadicIO $ do 36 | m <- pick $ choose (0,maxBound) :: PropertyM IO Int 37 | res <- run $ runOT 1024 $ do 38 | (pk, sk) <- ddhKeyGen 39 | ct <- ddhEnc pk (fromIntegral m) 40 | ddhDec sk ct 41 | assert (res == fromIntegral m) 42 | 43 | prop_messyModeCorrect :: Property 44 | prop_messyModeCorrect = testMode setupMessy 45 | 46 | prop_decModeCorrect :: Property 47 | prop_decModeCorrect = testMode setupDec 48 | 49 | testMode :: OT CRS -> Property 50 | testMode setup = once $ monadicIO $ do 51 | m <- pick $ choose (0,maxBound) :: PropertyM IO Int 52 | n <- pick $ choose (0,maxBound) :: PropertyM IO Int 53 | b <- pick arbitrary :: PropertyM IO Bool 54 | (m',n') <- run $ runOT 1024 $ do 55 | crs <- setup 56 | (pk, sk) <- keyGen crs b 57 | (x,y) <- enc crs pk (fromIntegral m, fromIntegral n) 58 | m' <- dec sk x 59 | n' <- dec sk y 60 | return (fromIntegral m', fromIntegral n') 61 | assert (sel b (m',n') == sel b (m,n)) -- can decrypt the chosen ciphertext 62 | assert (sel (not b) (m',n') /= sel (not b) (m,n)) -- and only the chosen ciphertext 63 | 64 | prop_convWorks :: Property 65 | prop_convWorks = monadicIO $ do 66 | bs <- BS.pack <$> pick (vectorOf 4 arbitrary) 67 | assert (bs == fromJust (i2ospOf 4 (os2ip bs))) 68 | 69 | prop_otProtoWorks :: Property 70 | prop_otProtoWorks = once $ monadicIO $ do 71 | m <- BS.pack <$> pick (vectorOf 16 arbitrary) 72 | n <- BS.pack <$> pick (vectorOf 16 arbitrary) 73 | b <- pick arbitrary 74 | port <- pick $ choose (1024,65536) 75 | run $ forkIO $ listenAt port (flip sendOT (m,n) . simpleConn) 76 | res <- run $ connectTo "localhost" port (flip recvOT b . simpleConn) 77 | assert (sel b (m,n) == res) 78 | 79 | prop_otExtWorks :: Property 80 | prop_otExtWorks = once $ monadicIO $ do 81 | let n = 1 82 | k <- buildKey <$> BS.pack <$> pick (vectorOf 16 arbitrary) 83 | pre (isJust k) 84 | let key = fromJust k 85 | x <- pick (vectorOf n (vectorOf 16 arbitrary)) 86 | y <- pick (vectorOf n (vectorOf 16 arbitrary)) 87 | b <- pick (vectorOf n arbitrary) 88 | port <- pick $ choose (1024,65536) 89 | run $ forkIO $ listenAt port (\c -> otSend (simpleConn c) key (zip (BS.pack <$> x) (BS.pack <$> y))) 90 | res <- fmap BS.unpack <$> (run $ connectTo "localhost" port (\c -> otRecv (simpleConn c) key b)) 91 | monitor (counterexample (show res)) 92 | monitor (counterexample (show (zipWith sel b (zip x y)))) 93 | assert (zipWith (sel) b (zip x y) == res) 94 | 95 | prop_bytes2Bits :: Property 96 | prop_bytes2Bits = monadicIO $ do 97 | bs <- BS.pack <$> pick (vectorOf 16 arbitrary) 98 | assert (bs == bits2Bytes (bytes2Bits 128 bs)) 99 | 100 | prop_bits2BytesLPad :: Property 101 | prop_bits2BytesLPad = monadicIO $ do 102 | n <- pick $ choose (1, 128) 103 | bs <- pick (vectorOf n arbitrary) 104 | assert $ bs == bytes2Bits n (lpad 16 (bits2Bytes bs)) 105 | 106 | sel :: Bool -> (a,a) -> a 107 | sel False (x,y) = x 108 | sel True (x,y) = y 109 | --------------------------------------------------------------------------------