hMPC (empty) → 0.1.0.0
raw patch · 18 files changed
+1671/−0 lines, 18 filesdep +HUnitdep +basedep +binarysetup-changed
Dependencies added: HUnit, base, binary, bytestring, cereal, containers, hMPC, hashable, hgmp, hslogger, lens, mtl, network, optparse-applicative, process, random, split, stm, time, vector
Files
- CHANGELOG.md +13/−0
- LICENSE +21/−0
- README.md +68/−0
- Setup.hs +2/−0
- app/Asyncoro.hs +237/−0
- app/FinFields.hs +72/−0
- app/Hgmp.hs +32/−0
- app/MpcTools.hs +14/−0
- app/Parser.hs +43/−0
- app/Runtime.hs +587/−0
- app/SecTypes.hs +49/−0
- app/Shamir.hs +66/−0
- app/Types.hs +36/−0
- demos/Id3gini.hs +194/−0
- hMPC.cabal +142/−0
- test/RuntimeTest.hs +52/−0
- test/ShamirTest.hs +26/−0
- test/TestMain.hs +17/−0
+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog for `hMPC` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2024-17-07 + +Initial release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License + +Copyright (c) 2024 Nick van Gils + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.
+ README.md view
@@ -0,0 +1,68 @@+<!-- [](https://mybinder.org/v2/gh/lschoe/mpyc/master) +[](https://app.travis-ci.com/lschoe/mpyc) +[](https://codecov.io/gh/lschoe/mpyc) +[](https://mpyc.readthedocs.io) +[](https://pypi.org/project/mpyc/) --> + +# hMPC Multiparty Computation in Haskell + +This hMPC library, written in the functional language Haskell, serves as a counterpart to the original [MPyC](https://github.com/lschoe/mpyc) library, written in the imperative language Python and developed by Berry Schoenmakers. + +hMPC supports secure *m*-party computation tolerating a dishonest minority of up to *t* passively corrupt parties, +where *m ≥ 1* and *0 ≤ t < m/2*. The underlying cryptographic protocols are based on threshold secret sharing over finite +fields (using Shamir's threshold scheme and optionally pseudorandom secret sharing). + +The details of the secure computation protocols are mostly transparent due to the use of sophisticated operator overloading +combined with asynchronous evaluation of the associated protocols. + +## Documentation + +See `demos` for Haskell programs with lots of example code. See `docs/basics.rst` for a basic secure computation example in Haskell. + +The initial reseach is part of a master's graduation project. For further reading, refer to the complementary master's thesis: [Multiparty Computation in Haskell: From MPyC to hMPC](https://research.tue.nl/en/studentTheses/multiparty-computation-in-haskell). + + +Original Python MPyC documentation: + +[Read the Docs](https://mpyc.readthedocs.io/) for `Sphinx`-based documentation, including an overview of the `demos`. + +The [MPyC homepage](https://www.win.tue.nl/~berry/mpyc/) has some more info and background. +<!-- [GitHub Pages](https://lschoe.github.io/mpyc/) for `pydoc`-based documentation. --> + + + +<!-- ## Installation --> + +<!-- Pure Python, no dependencies. Python 3.9+ (following [NumPy's deprecation policy](https://numpy.org/neps/nep-0029-deprecation_policy.html#support-table)). + +Run `pip install .` in the root directory (containing file `setup.py`).\ +Or, run `pip install -e .`, if you want to edit the MPyC source files. + +Use `pip install numpy` to enable support for secure NumPy arrays in MPyC, along with vectorized implementations. + +Use `pip install gmpy2` to run MPyC with the package [gmpy2](https://pypi.org/project/gmpy2/) for considerably better performance. + +Use `pip install uvloop` (or `pip install winloop` on Windows) to replace Python's default asyncio event loop in MPyC for generally improved performance. --> + +<!-- ### Some Tips --> + +<!-- - Try `run-all.sh` or `run-all.bat` in the `demos` directory to have a quick look at all pure Python demos. +Demos `bnnmnist.py` and `cnnmnist.py` require [NumPy](https://www.numpy.org/), demo `kmsurvival.py` requires +[pandas](https://pandas.pydata.org/), [Matplotlib](https://matplotlib.org/), and [lifelines](https://pypi.org/project/lifelines/), +and demo `ridgeregression.py` (and therefore demo `multilateration.py`) even require [Scikit-learn](https://scikit-learn.org/).\ +Try `np-run-all.sh` or `np-run-all.bat` in the `demos` directory to run all Python demos employing MPyC's secure arrays. +Major speedups are achieved due to the reduced overhead of secure arrays and vectorized processing throughout the +protocols. --> + +<!-- - To use the [Jupyter](https://jupyter.org/) notebooks `demos\*.ipynb`, you need to have Jupyter installed, +e.g., using `pip install jupyter`. An interesting feature of Jupyter is the support of top-level `await`. +For example, instead of `mpc.run(mpc.start())` you can simply use `await mpc.start()` anywhere in +a notebook cell, even outside a coroutine.\ +For Python, you also get top-level `await` by running `python -m asyncio` to launch a natively async REPL. +By running `python -m mpyc` instead you even get this REPL with the MPyC runtime preloaded! --> + +<!-- - Directory `demos\.config` contains configuration info used to run MPyC with multiple parties. +The file `gen.bat` shows how to generate fresh key material for SSL. To generate SSL key material of your own, first run +`pip install cryptography` (alternatively, run `pip install pyOpenSSL`). --> + +Copyright © 2024 Nick van Gils
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ app/Asyncoro.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +-- | This module provides basic support for asynchronous communication +-- and computation of secret-shared values. +module Asyncoro (createConnections, send, receive, Gather(..), async, asyncList, asyncListList, await, incPC, decreaseBarrier) where +import Network.Socket +import Network.Socket.ByteString (recv, sendAll) +import Control.Exception +import Control.Concurrent +import System.IO.Error +import Control.Monad +import Types +import Data.Function +import Data.List +import qualified Data.Map.Strict as Map +import qualified Data.Serialize as Enc +import qualified Data.ByteString as BS +import Data.Hashable +import Control.Monad.State +import SecTypes +import FinFields +import System.Log.Logger +import Text.Printf +import Parser + + +-- | Open connections with other parties, if any. +createConnections :: Int -> [Party] -> IO [Party] +createConnections myPid parties = do + let m = length parties + let listenPort = port $ parties !! myPid + sock <- socket AF_INET Stream 0 -- create socket + setSocketOption sock ReuseAddr 1 -- make socket immediately reusable - eases debugging. + bind sock (SockAddrInet (fromIntegral listenPort) 0) -- listen on TCP port 4242 + pid. + listen sock 1 -- set a max of 2 queued connections + serverParties <- replicateM myPid $ do + mvar <- newEmptyMVar + forkIO $ connectServer sock parties mvar + return mvar + + clientParties <- forM (drop (myPid+1) parties) $ \party -> do + mvar <- newEmptyMVar + forkIO $ connectClient myPid party mvar + return mvar + + channels <- mapM takeMVar (serverParties ++ clientParties) + logging INFO $ printf "All %d parties connected." m + + close sock + + -- necessary if --single-threaded bug + cap <- getNumCapabilities + logging INFO $ printf "All threads run on %d cores." cap + when (cap <= 1) (threadDelay 5000000) + + newDict <- newMVar Map.empty + newMVar <- newMVar 0 + emptyChan <- newChan + let selfParty = (parties !! myPid){outChan = emptyChan, sock = Nothing, dict = newDict, nbytesSent=newMVar} + return $ sortBy (compare `on` pid) (selfParty: channels) + + where + connectServer sock parties mvar = do + (conn, _) <- accept sock -- accept a connection and handle it + msg <- recv conn 1024 -- receive pid + case Enc.decode msg of + Right peer_pid -> initConnection conn (parties !! peer_pid) mvar + + connectClient pid peer mvar = do + addr <- head <$> getAddrInfo Nothing (Just (host peer)) (Just $ show (port peer)) + sock <- openSocket addr + res <- try @IOException $ connect sock (addrAddress addr) + case res of + Right _ -> do -- connection successful + sendAll sock (Enc.encode pid) --send pid + initConnection sock peer mvar + Left _ -> do -- exception + threadDelay 100000 + connectClient pid peer mvar + + initConnection sock peer mvar = do + newDict <- newMVar Map.empty + bytesMvar <- newMVar 1 -- one for the runSession to complete + outChan <- newChan + putMVar mvar peer{outChan = outChan, sock = Just sock, dict = newDict, nbytesSent=bytesMvar} + runConnection outChan sock newDict bytesMvar + + +-- read lines from the socket and insert into dictionary +runConnection :: Chan BS.ByteString -> Socket -> MVar Dict -> MVar Int -> IO () +runConnection chan sock dictMvar nbytesSent = do + reader <- forkIO $ forever $ do + dataToSend <- readChan chan + sendAll sock dataToSend + + handle (\(SomeException _) -> return ()) $ flip fix BS.empty $ \loop buffer_old -> + BS.append buffer_old <$> recv sock 1024 + >>= decodeMessageChecks dictMvar nbytesSent + >>= loop + >> return () + + killThread reader + + where + decodeMessageChecks dictMvar nbytesSent buffer = do + let bufferLength = BS.length buffer + if bufferLength < 4 + then return buffer + else do + let payload_length = _decode Enc.getInt32le (BS.take 4 buffer) + len_packet = payload_length + 12 + if bufferLength < len_packet + then return buffer + else decodeMessage buffer len_packet + + decodeMessage buffer len_packet = do + let (msg, leftover) = BS.splitAt len_packet buffer + pc = _decode Enc.getInt64le (BS.drop 4 buffer) + modifyMVar_ nbytesSent (return . (+ len_packet)) + modifyMVar_ dictMvar $ \dict -> + case Map.lookup pc dict of + Just mvar -> do + putMVar mvar (BS.drop 12 msg) + return $ Map.delete pc dict + Nothing -> do + mvar <- newMVar (BS.drop 12 msg) + return $ Map.insert pc mvar dict + decodeMessageChecks dictMvar nbytesSent leftover + + _decode decoder buffer = + case Enc.runGet (liftM fromIntegral decoder) buffer of + Right t -> t + +-- | Receive payload labeled with given pc from the peer. +receive :: Int -> Party -> SIO (MVar BS.ByteString) +receive pc party = liftIO $ modifyMVar (dict party) $ \dict -> do + case Map.lookup pc dict of + Just value -> return (Map.delete pc dict, value) + Nothing -> do + mvar <- newEmptyMVar + return ((Map.insert pc mvar dict), mvar) + +-- | Transform 'SecureTypes' into 'FiniteField' by reading the future 'MVar' share that contains a 'FiniteField' (blocking). +class Gather a where + type Result a :: * + gather :: a -> SIO (Result a) + +instance Gather SecureTypes where + type Result SecureTypes = FiniteField + gather = await . share + +instance Gather a => Gather [a] where + type Result [a] = [Result a] + gather = mapM gather + +instance (Gather a, Gather b) => Gather (a, b) where + type Result (a, b) = (Result a, Result b) + gather (x, y) = do + resultX <- gather x + resultY <- gather y + return (resultX, resultY) + +instance (Gather a, Gather b, Gather c) => Gather (a, b, c) where + type Result (a, b, c) = (Result a, Result b, Result c) + gather (x, y, z) = do + resultX <- gather x + resultY <- gather y + resultZ <- gather z + return (resultX, resultY, resultZ) + +-- | Read the value from the future MVar (blocking). +await :: MVar a -> SIO a +await = liftIO . readMVar + + +-- | Send payload labeled with pc to the peer. +-- +-- Message format consists of three parts: +-- +-- 1. pc (8 bytes signed int) +-- +-- 2. payload_size (4 bytes unsigned int) +-- +-- 3. payload (byte string of length payload_size). +send :: Int -> BS.ByteString -> Party -> SIO () +send pc payload party = do + let payload_size = (BS.length payload) + let bytes = ((Enc.runPut ( + (Enc.putInt32le . fromIntegral) payload_size + >> (Enc.putInt64le . fromIntegral) pc)) <> payload) + liftIO $ writeChan (outChan party) bytes + +-- | increment program counter in state. +incPC :: SIO Int +incPC = do + pcOld <- gets pc + modify (\env -> env{pc = (+1) pcOld}) + gets pc + +-- | 'forkIO' the action monad asynchronously and return future 'MVar'. +-- Provide the given state monad with its own program counter space. +async :: SIO a -> SIO (MVar a) +async = \action -> head <$> asyncList 1 ((:[]) <$> action) + +asyncList :: Int -> SIO [a] -> SIO [MVar a] +asyncList l = \action -> head <$> asyncListList 1 l ((:[]) <$> action) + +asyncListList :: Int -> Int -> SIO [[a]] -> SIO [[MVar a]] +asyncListList l1 l2 = \action -> do + pcOld <- incPC + state <- get + outslist <- replicateM l1 $ replicateM l2 (liftIO $ newEmptyMVar) + + let newState = state{pc = hash $ show pcOld} + barrier = forkIOBarrier state + action2 = do + fieldslist <- runSIO action newState + zipWithM_ (zipWithM_ putMVar) outslist fieldslist + decreaseBarrier barrier + + liftIO $ modifyMVar_ (count barrier) (return . (+1)) + if (noAsync . options) state + then liftIO $ action2 + else void $ liftIO $ forkIO $ action2 + + return outslist + +decreaseBarrier :: Barrier -> IO () +decreaseBarrier (Barrier countVar signalVar) = + modifyMVar_ countVar $ \n -> do + let n' = n - 1 + if n' == 0 + then do + putMVar signalVar () + return n' + else return n'
+ app/FinFields.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TemplateHaskell #-} + +-- TODO +-- Taking square roots and quadratic residuosity tests supported as well. +-- Moreover, (multidimensional) arrays over finite fields are available +-- with operators +,-,*,/ for convenient and efficient NumPy-based +-- vectorized processing next to operator @ for matrix multiplication. +-- Much of the NumPy API can be used to manipulate these arrays as well. + +{- | +This module supports finite (Galois) fields. + +Function 'gf' creates types implementing finite fields. +-} +module FinFields (FiniteField(..), FiniteFieldMeta(..), gf, toBytes, fromBytes) where + +import Hgmp as Hgmp +import Data.Bits +import qualified Data.ByteString as B +import Data.List.Split + + +-- | Instantiate an object from a field and subsequently apply overloaded +-- operators such as @('+')@, @('-')@, @('*')@, @('/')@ etc., to compute with field elements. +data FiniteField = FiniteField {meta :: FiniteFieldMeta, value :: Integer} + | Literal {value :: Integer} deriving Show +data FiniteFieldMeta = FiniteFieldMeta {modulus :: Integer, byteLength :: Int} deriving Show + + +-- TODO: irreducible polynomial, also creates corresponding array type. +-- | Create a finite (Galois) field for given modulus (prime number). +gf :: Integer -> FiniteField +gf modulus = let byteLength = ((ceiling . logBase 2 . fromIntegral) modulus + 7) `shiftR` 3 + in FiniteField{meta = FiniteFieldMeta {modulus = modulus, byteLength = byteLength}} + +-- | Multiplicative inverse, Division. +instance Fractional FiniteField where + recip a = a{value = Hgmp.invert (value a) (modulus $ meta a)} + (/) a b = a * recip (case b of Literal val -> a{value = val}; _ -> b) + +-- | Equality test. +instance Eq FiniteField where + (==) f1 f2 = (value f1) == (value f2) + +-- | Addition, Subtraction, Multiplication. +instance Num FiniteField where + (+) = _applyOpFF (+) + (-) = _applyOpFF (-) + (*) = _applyOpFF (*) + fromInteger a = Literal a + +_applyOpFF :: (Integer -> Integer -> Integer) -> FiniteField -> FiniteField -> FiniteField +_applyOpFF f (FiniteField meta val1) (FiniteField _ val2) = _makeFF meta (f val1 val2) +_applyOpFF f (FiniteField meta val1) (Literal val2) = _makeFF meta (f val1 val2) +_applyOpFF f (Literal val1) (FiniteField meta val2) = _makeFF meta (f val1 val2) +_applyOpFF f (Literal val1) (Literal val2) = Literal (f val1 val2) + +_makeFF :: FiniteFieldMeta -> Integer -> FiniteField +_makeFF meta val = FiniteField meta (val `mod` modulus meta) + +-- | Return byte string representing the given list/ndarray of integers x. +toBytes :: Int -> [Integer] -> B.ByteString +toBytes byteLength x = B.pack $ concatMap (\a -> map (\i -> fromIntegral ((a `shiftR` (i * 8)) .&. 0xFF)) [0..byteLength-1]) x + +-- | Return the list of integers represented by the given byte string. +fromBytes :: Int -> B.ByteString -> [Integer] +fromBytes n bytes = map (foldr unstep 0) (chunksOf n $ B.unpack bytes) + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + + +
+ app/Hgmp.hs view
@@ -0,0 +1,32 @@+-- | This module collects all hGMP functions used by hMPC. +module Hgmp (isPrime, prevPrime, invert) where + +import Numeric.GMP.Utils (withInInteger, withOutInteger_) +import Numeric.GMP.Raw.Safe +import System.IO.Unsafe (unsafePerformIO) + + +-- | Return True if x is probably prime, else False if x is +-- definitely composite +isPrime :: Integer -> Bool +isPrime x = unsafePerformIO (withInInteger x (flip mpz_probab_prime_p 25)) > 0 + + +-- | Return the greatest probable prime number < x, if any. +prevPrime :: Integer -> Integer +prevPrime x + | x <= 2 = 0 + | x == 3 = 2 + | otherwise = _prevPrime (x - (1 + (x `mod` 2))) + where + _prevPrime x + | isPrime x = x + | otherwise = _prevPrime (x-2) + +-- | Return y such that @x*y == 1 modulo m@. +invert :: Integer -> Integer -> Integer +invert x m = unsafePerformIO $ + withOutInteger_ $ \rop -> + withInInteger x $ \op1 -> + withInInteger m $ \op2 -> + mpz_invert rop op1 op2
+ app/MpcTools.hs view
@@ -0,0 +1,14 @@+module MpcTools where + + + +-- reduce :: (SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes) -> [SIO SecureTypes] -> Maybe (SIO SecureTypes) -> SIO SecureTypes +-- reduce _ [] (Just iv) = iv +-- reduce _ [] Nothing = error "reduce: empty list with no initial value" +-- reduce _ [x] _ = x +-- reduce f xs iv = +-- let reduce' [] = [] +-- reduce' [y] = [y] +-- reduce' (y1:y2:ys) = f y1 y2 : reduce' ys +-- in head (reduce' xs') +-- where xs' = maybe xs (:xs) iv
+ app/Parser.hs view
@@ -0,0 +1,43 @@+module Parser (getArgParser, getArgParserExtra, Options(..)) where + +import Options.Applicative + +-- | Return parser results for command line arguments passed to the hMPC runtime. +getArgParser :: IO Options +getArgParser = execParser $ info (sample <**> helper) fullDesc + +-- | Return parser for command line arguments passed to the hMPC runtime. +getArgParserExtra :: Parser a -- | include a user specified parser + -> IO (Options, a) +getArgParserExtra pars = execParser $ info (((,) <$> sample <*> pars) <**> helper) fullDesc + +data Options = Options + { parsParties :: [String], m :: Integer, myPid :: Integer, + threshold :: Integer, basePort :: Integer, secParam :: Int, noAsync :: Bool, nrThreads :: Maybe Int} + +sample :: Parser Options +sample = Options + <$> many (strOption + ( short 'P' <> metavar "addr" + <> help "use addr=host:port per party (repeat m times)" )) + <*> option auto + ( short 'M' <> showDefault <> value (-1) <> metavar "INT" + <> help "use m local parties (and run all m, if i is not set)" ) + <*> option auto + ( short 'I' <> long "index" <> value (-1) <> metavar "INT" + <> help "set index of this local party to i, 0<=i<m" ) + <*> option auto + ( short 'T' <> long "threshold" <> showDefault <> value (-1) <> metavar "INT" + <> help "threshold t, 0<=t<m/2" ) + <*> option auto + ( short 'B' <> long "base-port" <> showDefault <> value 4242 <> metavar "b" + <> help "use port number b+i for party i" ) + <*> option auto + ( short 'K' <> long "sec-param" <> showDefault <> value 30 <> metavar "INT" + <> help "security parameter k, leakage probability 2**-k" ) + <*> switch + ( long "no-async" + <> help "disable asynchronous evaluation" ) + <*> optional ( option auto + ( long "threads" <> metavar "L" + <> help "Set the number of Haskell threads that can run truly simultaneously."))
+ app/Runtime.hs view
@@ -0,0 +1,587 @@+{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + +{- | +The hMPC runtime module is used to execute secure multiparty computations. + +Parties perform computations on secret-shared values by exchanging messages. +Shamir's threshold secret sharing scheme is used for finite fields of any order +exceeding the number of parties. hMPC provides many secure data types, ranging +from numeric types to more advanced types, for which the corresponding operations +are made available through Haskell's mechanism for operator overloading. +-} +module Runtime (secIntGen, secFldGen, runMpc, runMpcWithArgs, runSession, Input, input, Output(..), transfer, (.+), (.-), (.*), (./), srecip, (.^), (.<), (.<=), (.>), (.==), isZero, isZeroPublic, ssignum, argmaxfunc, argmax, smaximum, ssum, sproduct,sall, randomBits, inProd, schurProd, matrixProd, IfElse(..), ifElseList, async, await) where + +import Control.Lens.Traversal +import Data.Maybe +import Data.List.Split +import Data.List +import Data.Bits +import Text.Printf +import System.Info (os) +import Control.Concurrent +import Control.Monad.State +import Asyncoro +import System.Process +import System.Environment +import System.Random +import Shamir +import Prelude +import Types +import Network.Socket +import Parser +import SecTypes +import FinFields +import Data.Serialize (encode, decode, Serialize) +import qualified Data.ByteString as BS +import Data.Time +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler.Simple +import System.Log.Handler (setFormatter) +import System.IO +import Options.Applicative (Parser) + +-- | Runs 'MPC' computation +runMpc :: SIO a -> IO a +runMpc = \action -> do + conf <- Runtime.setup =<< Parser.getArgParser + runSIO action conf + +-- | Runs 'MPC' computation with user arguments +runMpcWithArgs :: Parser b -> (b -> SIO a) -> IO a +runMpcWithArgs parser = \action -> do + (mpcOpts, userOpts) <- Parser.getArgParserExtra parser + conf <- Runtime.setup mpcOpts + runSIO (action userOpts) conf + +-- | Start and Stop hMPC runtime +runSession :: SIO a -> SIO a +runSession action = do + env <- Runtime.start + liftIO $ runSIO (do val <- action; Runtime.shutdown; return val) env + +exchangeShares :: [BS.ByteString] -> SIO [MVar BS.ByteString] +exchangeShares inShares = do + parties <- gets parties + + forM_ (zip parties inShares) $ \(party, bytes) -> + when (isJust $ sock party) (sendMessage bytes party) + + forM (zip parties [0..]) $ \(party, index) -> + case sock party of + Just _ -> receiveMessage party + Nothing -> liftIO $ newMVar (inShares !! index) + + +-- | Transfer serializable Haskell objects +transfer :: (Serialize a) => a -> SIO (MVar [a]) +transfer val = do + parties <- gets parties + let encVal = (encode val) + out <- async $ do + forM_ parties $ \party -> + when (isJust $ sock party) (sendMessage encVal party) + + forM parties $ \party -> + case sock party of + Just _ -> do + bytes <- await =<< receiveMessage party + case (decode bytes) of + Right msg -> return msg + Nothing -> return val + return out + + +-- | Input x to the computation. +-- +-- Value x is a secure object, or a list of secure objects. +class Input a b | a -> b where + input :: a -> SIO b + +instance Input (SIO SecureTypes) [SIO SecureTypes] where + input a = map head <$> input [a] + +instance Input [SIO SecureTypes] [[SIO SecureTypes]] where + input xm = do + x <- sequence xm + Env{parties=parties, options=opts, gen=_gen} <- get + + outslist <- asyncListList (fromInteger (m opts)) (length x) $ do + xf <- gather x + let ftype = (head xf) + length = (byteLength . meta) ftype + (inShares, g'') = Shamir.randomSplit ftype xf (threshold opts) (m opts) _gen + modify (\env -> env{gen = g''}) + + forM_ (zip parties inShares) $ \(party, val) -> + when (isJust $ sock party) (sendMessage (toBytes length val) party) + + forM (zip parties [0..]) $ \(party, index) -> do + shares <- case sock party of + Just _ -> fromBytes length <$> (await =<< receiveMessage party) + Nothing -> return (inShares !! index) + return $ map (\share -> ftype{value = share}) shares + + return $ (map . map) (\out -> return (head x){share = out}) outslist + +class Reshare a b | a -> b where + reshare :: a -> SIO b + +instance Reshare FiniteField FiniteField where + reshare a = head <$> reshare [a] + +instance Reshare [FiniteField] [FiniteField] where + reshare x = do + Env{parties=parties, options=opts, gen=_gen} <- incPC >> get + let ftype = head x + length = (byteLength . meta) ftype + (s, g'') = Shamir.randomSplit ftype x (threshold opts) (m opts) _gen + inShares = map (toBytes length) s + modify (\env -> env{gen = g''}) + shares <- exchangeShares inShares + points <- forM (zip shares parties) $ \(share, party) -> do + val <- fromBytes length <$> (await share) + return ((pid party) + 1, val) + + return (Shamir.recombine ftype points) + + +-- | Output the value of x to the receivers specified. +-- Value x is a secure object, or a list of secure objects. +-- +-- A secure integer is output as a Haskell Integer +class Output a b | a -> b where + output :: a -> SIO (MVar b) + +instance Output (SIO SecureTypes) Integer where + output a = _output [a] head + +instance Output [SIO SecureTypes] [Integer] where + output a = _output a id + +_output :: [SIO SecureTypes] -> ([Integer] -> b) -> SIO (MVar b) +_output xm convert = do + x <- sequence xm + parties <- gets parties + out <- async $ do + s <- gather x + let inShares = map value s + length = (byteLength . meta . head) s + let inSharesEncoded = toBytes length inShares + forM_ parties $ \party -> + when (isJust $ sock party) (sendMessage inSharesEncoded party) + + points <- forM parties $ \party -> do + shares <- case sock party of + Just _ -> fromBytes length <$> (await =<< receiveMessage party) + Nothing -> return inShares + return ((pid party) + 1, shares) + + let y = map value (recombine ((field . head) x) points) + return $ convert y + return out + + +shutdown :: SIO () +shutdown = do + Env{parties=parties, options=opt, forkIOBarrier=barrier, startTime=_startTime} <- get + + -- wait until all forkIO tasks have completed + liftIO $ Asyncoro.decreaseBarrier barrier + liftIO $ takeMVar (signal barrier) + + endTime <- liftIO $ getCurrentTime + bytes <- mapM (await . nbytesSent) parties + let elapsedTime = diffUTCTime endTime _startTime + liftIO $ logging INFO $ printf "Computation time: %s sec | bytes sent: %d \n" (show elapsedTime) (sum bytes) + + -- Synchronize with all parties before shutdown + await =<< transfer (myPid opt) + + -- close connections peer_pid > pid + liftIO $ forM_ (filter (\x -> ((pid x) > (myPid opt))) parties) $ \party -> do + case (sock party) of + Just _sock -> close _sock + +-- | Secure addition of a and b. +(.+) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.+) am bm = do + (a, b) <- sequenceOf both (am, bm) + out <- async $ do + (af, bf) <- gather (a, b) + return (af + bf) + return (_coerce a b){share = out} + +-- | Secure subtraction of a and b. +(.-) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.-) am bm = do + (a, b) <- sequenceOf both (am, bm) + out <- async $ do + (af, bf) <- gather (a, b) + return (af - bf) + return (_coerce a b){share = out} + +-- | Secure multiplication of a and b. +(.*) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.*) am bm = do + (a, b) <- sequenceOf both (am, bm) + out <- async $ do + (af, bf) <- gather (a, b) + reshare (af * bf) + return (_coerce a b){share = out} + +-- | Secure division of a by b, for nonzero b. +(./) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(./) am bm = do + (recip bm) * am + +-- | Secure reciprocal (multiplicative field inverse) of a, for nonzero a. +srecip :: SIO SecureTypes -> SIO SecureTypes +srecip am = do + a <- am + out <- async $ fix $ \loop -> do + [r] <- _randoms a 1 Nothing + ar <- await =<< output ((return a) .* (return r)) + if (ar == 0) + then loop + else do + rfld <- gather r + return (rfld / rfld{value = ar}) + return a{share = out} + +-- | Secure exponentiation a raised to the power of b, for public integer b. +(.^) :: SIO SecureTypes -> Integer -> SIO SecureTypes +(.^) am b = do + a <- am + sproduct $ replicate (fromIntegral b) (return a) + +-- | Secure comparison a < b. +(.<) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.<) am bm = ssignum True False (am - bm) + +-- | Secure comparison a <= b. +(.<=) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.<=) am bm = 1 - (bm .< am) + +-- | Secure comparison a > b. +(.>) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.>) am bm = (bm .< am) + +-- | Secure comparison a == b. +(.==) :: SIO SecureTypes -> SIO SecureTypes -> SIO SecureTypes +(.==) am bm = isZero (am - bm) + +-- | Secure zero test a == 0. +isZero :: SIO SecureTypes -> SIO SecureTypes +isZero am = do + a <- am + case a of + SecFld {field=fld} -> (1 - ((return a) .^ ((modulus . meta) fld - 1))) -- todo modulus = order + _ -> ssignum False True (return a) + +-- | Secure public zero test of a. +isZeroPublic :: SIO SecureTypes -> SIO (MVar Bool) +isZeroPublic am = do + a <- am + [r] <- _randoms a 1 Nothing + out <- async $ do + (afld, rfld) <- gather (a, r) + res <- await =<< (output $ setShare a (value (afld * rfld))) + return (res == 0) + return out + +-- | Secure sign(um) of a, return -1 if a < 0 else 0 if a == 0 else 1. +-- +-- If Boolean flag LT is set, perform a secure less than zero test instead, and +-- return 1 if a < 0 else 0, saving the work for a secure equality test. +-- If Boolean flag EQ is set, perform a secure equal to zero test instead, and +-- return 1 if a == 0 else 0, saving the work for a secure comparison. +ssignum :: Bool -> Bool -> SIO SecureTypes -> SIO SecureTypes +ssignum True True _ = error "lt and eq both true" +ssignum lt eq am = do + a <- am + opt <- gets options + let l = (bitLength a) + r_bits <- sequence =<< randomBits (return a) l False + [r] <- _randoms a 1 $ Just $ 1 `shiftL` (secParam opt) + out <- async $ do + r_bits_fld <- gather r_bits + let r_modl = foldr (\x acc -> (acc `shiftL` 1) + (value x)) 0 r_bits_fld + + (r_divl, af) <- gather (r, a) + let a_rmodl = af + fromInteger ((1 `shiftL` l) + r_modl) + c <- (`mod` (1 `shiftL` l)) + <$> (await =<< output (setShare a (value $ a_rmodl + fromInteger ((value r_divl) `shiftL` l)))) + + z1 <- if not eq then do + s_sign <- value <$> (randomBits (return a) 1 True >>= head >>= gather) + + let (e, sumXors) = foldl (\(e, sumXors) (bit, i) -> + let c_i = ((c `shiftR` i) .&. 1) + in (setShare a (s_sign + (value bit) - c_i + 3 * sumXors) : e, + sumXors + if c_i == 1 then 1 - (value bit) else (value bit))) + ([], 0) (zip (reverse r_bits_fld) [l-1, l-2..]) + + g <- await =<< (isZeroPublic $ sproduct (setShare a (s_sign - 1 + 3*sumXors) : e)) + let h = if g then 3 - s_sign else 3 + s_sign + return $ (fromInteger (c + (h `shiftL` (l - 1))) - a_rmodl) / fromInteger (1 `shiftL` l) + else return FiniteField{} + + if not lt then do + h <- await . share =<< sall (map (\(bit, i) -> + setShare a $ value $ if ((c `shiftR` i) .&. 1) == 1 then bit else 1 - bit) (zip r_bits_fld [0..])) + if eq then return h + else reshare ((h - 1) * (2*z1 - 1)) + else return z1 + + return a{share = out} + +argmaxfunc :: [[SIO SecureTypes]] -> ([SIO SecureTypes] -> [SIO SecureTypes] -> SIO SecureTypes) -> SIO (SIO SecureTypes, [SIO SecureTypes]) +argmaxfunc [xm] _ = do + x <- sequence xm + return (setShare (head x) 0, map return x) +argmaxfunc x f = do + let n = length x + let (x0, x1) = splitAt (n `div` 2) x + (i0, m0) <- argmaxfunc x0 f + (i1, m1) <- argmaxfunc x1 f + c <- return <$> f m0 m1 + a <- ifElse c (i1 + fromIntegral (n `div` 2)) i0 + m <- ifElse c m1 m0 + return (return a, m) + + +-- | Secure argmax of all given elements in x. +-- +-- In case of multiple occurrences of the maximum values, +-- the index of the first occurrence is returned. +argmax :: [SIO SecureTypes] -> SIO (SIO SecureTypes, SIO SecureTypes) +argmax [xm] = do + x <- xm + return (setShare x 0, return x) +argmax x = do + let n = length x + let (x0, x1) = splitAt (n `div` 2) x + (i0, m0) <- argmax x0 + (i1, m1) <- argmax x1 + c <- return <$> (m0) .< (m1) + a <- ifElse c (i1 + fromIntegral (n `div` 2)) i0 + m <- ifElse c m1 m0 + return (return a, return m) + +-- | Secure maximum of all given elements in x, similar to Haskell's built-in maximum. +smaximum :: [SIO SecureTypes] -> SIO SecureTypes +smaximum [a] = a +smaximum x = do + let (x0, x1) = splitAt (length x `div` 2) x + m0 <- return <$> smaximum x0 + m1 <- return <$> smaximum x1 + (m0 .< m1) * (m1 - m0) + m0 + +-- | Secure sum of all elements in x, similar to Haskell's built-in sum. +ssum :: [SIO SecureTypes] -> SIO SecureTypes +ssum xm = do + x <- sequence xm + out <- async $ sum <$> gather x + return (head x){share = out} + +-- | Secure product of all elements in x, similar to Haskell's product. +-- +-- Runs in log_2 len(x) rounds). +sproduct :: [SIO SecureTypes] -> SIO SecureTypes +sproduct xm = do + x <- sequence xm + out <- async $ head <$> iterate (\xold -> do + (xmul, leftover) <- pairwise (*) <$> xold + (leftover ++) <$> reshare xmul) (gather x) !! ((ceiling . logBase 2 . fromIntegral) (length x)) + return (head x){share = out} + +-- | Secure all of elements in x, similar to Haskell's built-in all. +-- +-- Elements of x are assumed to be either 0 or 1 (Boolean). +-- Runs in log_2 len(x) rounds). +sall :: [SIO SecureTypes] -> SIO SecureTypes +sall xm = do + x <- sequence xm + out <- async $ head <$> iterate (\xold -> do + (xmul, leftover) <- pairwise (*) <$> xold + (leftover ++) <$> reshare xmul) (gather x) !! ((ceiling . logBase 2 . fromIntegral) (length x)) + return (head x){share = out} + +-- | Return n secure random values of the given type in the given range. +_randoms :: SecureTypes -> Integer -> Maybe Integer -> SIO [SecureTypes] +_randoms st n bound = do + t <- threshold <$> (gets options) + (g', g'') <- System.Random.split <$> gets gen + let fld = field st + _bound = case bound of + Just b -> 1 `shiftL` max 0 ((floor . logBase 2 . fromIntegral) (b `div` (t + 1))) + Nothing -> (modulus . meta) fld -- todo modulus = order + x = take (fromIntegral n) $ randomRs (0, _bound - 1) g' + modify (\env -> env{gen = g''}) + xlist <- input $ map (\rand -> do + randmvar <- liftIO $ newMVar fld{value = rand} :: SIO (MVar FiniteField) + return st{share = randmvar}) x + forM (transpose xlist) $ \_x -> ssum _x + +-- | Return n secure uniformly random bits of the given type. +randomBits :: SIO SecureTypes -> Int -> Bool -> SIO [SIO SecureTypes] +randomBits stm n signed = do + st <- stm + (g', g'') <- System.Random.split <$> gets gen + let x = take (fromIntegral n) $ randomRs (0, 1) g' + modify (\env -> env{gen = g''}) + xlist <- input $ map (\bit -> do + randmvar <- liftIO $ newMVar (field st){value = ((2*bit)-1)} :: SIO (MVar FiniteField) + return st{share = randmvar}) x + + secbits <- forM (transpose xlist) $ \x -> do + let secbit = sproduct x + if signed then secbit + else (secbit + 1) * fromInteger (((modulus . meta . field) st + 1) `shiftR` 1) -- todo modulus = characteristics + + return $ map (\secbit -> return secbit) secbits + +-- | Secure dot product of x and y (one resharing). +inProd :: [SIO SecureTypes] -> [SIO SecureTypes] -> SIO SecureTypes +inProd xm ym = do + (x, y) <- sequenceOf (both . traversed) (xm, ym) + out <- async $ do + (xf, yf) <- gather (x, y) + reshare $ sum $ zipWith (*) xf yf + return (head x){share = out} + +-- | Secure entrywise multiplication of vectors x and y. +schurProd :: [SIO SecureTypes] -> [SIO SecureTypes] -> SIO [SIO SecureTypes] +schurProd xm ym = do + (x, y) <- sequenceOf (both . traversed) (xm, ym) + outs <- asyncList (length x) $ do + (xf, yf) <- gather (x, y) + reshare $ zipWith (*) xf yf + return $ map (\out -> return (head x){share = out}) outs + +-- | Secure matrix product of A with (transposed) B. +matrixProd :: [[SIO SecureTypes]] -> [[SIO SecureTypes]] -> Bool -> SIO [[SIO SecureTypes]] +matrixProd am bm tr = do + (a, b) <- sequenceOf (both . traversed . traversed) (am, bm) + let n2 = if tr then (length b) else (length (head b)) + outslist <- asyncListList (length a) n2 $ do + (af, bf) <- gather (a, b) + let bft = if tr then bf else transpose bf + chunksOf n2 <$> reshare (concat [[sum $ zipWith (*) ai bi | bi <- bft] | ai <- af]) + + return $ (map . map) (\out -> return ((head . head) a){share = out}) outslist + +-- | Secure selection between x and y based on condition c. +class IfElse a b | a -> b where + ifElse :: SIO SecureTypes -> a -> a -> SIO b + +instance IfElse (SIO SecureTypes) (SecureTypes) where + ifElse cm xm ym = do + y <- return <$> ym + cm * (xm - y) + y + +instance IfElse [SIO SecureTypes] [SIO SecureTypes] where + ifElse = ifElseList + +ifElseList :: SIO SecureTypes -> [SIO SecureTypes] -> [SIO SecureTypes] -> SIO [SIO SecureTypes] +ifElseList am xm ym = do + (x, y) <- sequenceOf (both . traversed) (xm, ym) + a <- am + outs <- asyncList (length x) $ do + (af, xf, yf) <- gather (a, x, y) + reshare $ map (\(x_i, y_i) -> x_i{value = (value af) * ((value x_i) - (value y_i)) + (value y_i)}) (zip xf yf) + + return $ map (\out -> return (head x){share = out}) outs + +randomR' :: (Integer, Integer) -> SIO Integer +randomR' range = do + _gen <- gets gen + let (value, newGen) = randomR range _gen + modify (\env -> env{gen = newGen}) + return value + +pairwise :: (a -> a -> a) -> [a] -> ([a], [a]) +pairwise _ [] = ([],[]) +pairwise _ [x] = ([],[x]) +pairwise f (x:y:xs) = + let (z, leftover) = pairwise f xs + in (f x y : z, leftover) + +receiveMessage :: Party -> SIO (MVar BS.ByteString) +receiveMessage party = do + pc <- gets pc + Asyncoro.receive pc party + +-- | Send data to given peer, labeled by current program counter. +sendMessage :: BS.ByteString -> Party -> SIO () +sendMessage bytes party = do + pc <- gets pc + Asyncoro.send pc bytes party + +-- Start the hMPC runtime. +start :: SIO Env +start = do + Env{parties=parties, options=opt} <- get + liftIO $ do + parties <- Asyncoro.createConnections (fromInteger $ myPid opt) parties + countVar <- newMVar 1 + gen <- newStdGen + signalVar <- newEmptyMVar + startTime <- getCurrentTime + return $ Env parties 0 opt (Barrier countVar signalVar) gen startTime + +setup :: Options -> IO Env +setup opt = do + setNumCapabilities =<< maybe getNumCapabilities return (nrThreads opt) + h <- streamHandler stdout INFO >>= \lh -> return $ + setFormatter lh (tfLogFormatter "%Y-%m-%d %H:%M:%S%Q" "$time $msg") + updateGlobalLogger rootLoggerName (setHandlers [h] . setLevel INFO) + Env{options = _opt, parties=_parties} <- if null (parsParties opt) + then do + let _m = if (m opt < 0) then 1 else (m opt) + when (_m > 1 && (myPid opt) == -1) $ do + exPath <- getExecutablePath + args <- getArgs + forM_ [1..(_m-1)] $ \i -> do + let cmdLine = printf "%s %s -I %d" exPath (unwords args) i + createProcess (shell $ + if os == "mingw32" then ("start " ++ cmdLine) + else if os == "darwin" then printf "osascript -e 'tell application \"Terminal\" to do script \"%s\"'" cmdLine + else "") + + let _mypid = if (myPid opt) >= 0 then (myPid opt) else 0 + _parties = map (\i -> mkParty i "127.0.0.1" ((basePort opt) + i)) [0.._m-1] + _noASync = _m == 1 && ((noAsync opt) || not ((m opt) < 0)) + return Env{options = opt{myPid = _mypid, m = _m, noAsync = _noASync}, parties = _parties} + else do + let addresses = map (\addr -> splitOn ":" addr) (parsParties opt) + _mypid = maybe (myPid opt) fromIntegral (elemIndex "" (map head addresses)) + _parties = map (\(i, [host, port]) -> mkParty i (if null host then "127.0.0.1" else host) (read port)) (zip [0..] addresses) + _m = (fromIntegral . length) _parties + return Env{options = opt{myPid = _mypid, m = _m}, parties = _parties} + + let threshold = ((m _opt)-1) `div` 2 + return Env{options = _opt{threshold = threshold}, parties = _parties} + where + mkParty pid host port = Party{pid = pid, host = host, port = port} + + +-- secure types operator overloading +instance Num (SIO SecureTypes) where + (*) = (.*) + (+) = (.+) + (-) = (.-) + signum = ssignum False False + fromInteger i = + SecTypes.Literal <$> (liftIO $ newMVar $ FinFields.Literal i) + +instance Fractional (SIO SecureTypes) where + (/) = (./) + recip = srecip + +_coerce :: SecureTypes -> SecureTypes -> SecureTypes +_coerce (SecTypes.Literal _) f2 = f2 +_coerce f1 _ = f1 +
+ app/SecTypes.hs view
@@ -0,0 +1,49 @@+{- | +This module collects basic secure (secret-shared) types for hMPC. + +Secure number types all use common base classes, which +ensures that operators such as +,* are defined by operator overloading. +-} +module SecTypes where + +import Hgmp +import Data.Bits +import Types +import Control.Concurrent.MVar +import Control.Monad.State +import FinFields +import Parser + +-- | A secret-shared object. +-- +-- An MPC protocol operates on secret-shared objects of type SecureObject. +-- The basic Haskell operators are overloaded instances by SecureTypes classes. +-- An expression like a * b will create a new SecureObject, which will +-- eventually contain the product of a and b. The product is computed +-- asynchronously, using an instance of a specific cryptographic protocol. +data SecureTypes = + -- | Base class for secure (secret-shared) numbers. + SecFld {field :: FiniteField, share :: MVar FiniteField, bitLength :: Int} + -- | Base class for secure (secret-shared) finite field elements. + | SecInt {field :: FiniteField, share :: MVar FiniteField, bitLength :: Int} + | Literal {share :: MVar FiniteField} + +-- | Secure l-bit integers ('SecInt'). +secIntGen :: Int -> SIO (Integer -> SIO SecureTypes) +secIntGen l = do + k <- secParam <$> gets options + let field = FinFields.gf (Hgmp.prevPrime $ 1 `shiftL` (l + k + 2)) + return $ setShare $ SecInt {field = field, bitLength = l} + + +-- | Secure finite field ('SecFld') of order q = p +-- where p is a prime number +secFldGen :: Integer -> (Integer -> SIO SecureTypes) +secFldGen pnew = let field = FinFields.gf pnew + bitLength = (ceiling . logBase 2 . fromIntegral) pnew + in setShare $ SecFld {field = field, bitLength = bitLength} + +setShare :: SecureTypes -> Integer -> SIO SecureTypes +setShare sectype val = do + mvar <- liftIO $ newMVar (field sectype){value = val} + return $ sectype {share = mvar}
+ app/Shamir.hs view
@@ -0,0 +1,66 @@+ +-- TODO: Pseudorandom secret sharing (PRSS) allows one to share pseudorandom +-- secrets without any communication, as long as the parties +-- agree on a (unique) common public input for each secret. +-- PRSS relies on parties having agreed upon the keys for a pseudorandom +-- function (PRF). +{- | +Module for information-theoretic threshold secret sharing. + +Threshold secret sharing assumes secure channels for communication. +-} +module Shamir (randomSplit, _recombinationVector, recombine, IdSharesPair) where + +import Control.Monad +import FinFields +import System.Random +import Data.List + +-- | Couples a ID pi to the share list si. +type IdSharesPair = (Integer, [Integer]) + + + +-- | Split each secret given in s into m random Shamir shares. +-- +-- The (maximum) degree for the Shamir polynomials is t, @0 <= t < m@. +-- Return matrix of shares, one row per party. +randomSplit :: (RandomGen g) => FiniteField -> [FiniteField] -> Integer -> Integer -> g -> ([[Integer]], g) +randomSplit field s t m g = let (g', shares) = mapAccumR h g (map value s) + in (transpose shares, g') + where + randoms gen len bound = let (gen1, gen2) = split gen + _rands = take len $ randomRs (0, bound) gen1 + in (_rands, gen2) + h g' s_h = let (coefs, g'') = randoms g' (fromIntegral t) (modulus $ meta field) + shares = map (\i1 -> ((s_h + (poly coefs i1)) `mod` (modulus $ meta field))) [1..m] + in (g'', shares) + -- polynomial f(X) = s[h] + c[t-1] X + c[t-2] X^2 + ... + c[0] X^t + poly c i1 = foldr (\c_j y -> (y + c_j) * i1) 0 c + + +-- | Compute and store a recombination vector. +-- +-- A recombination vector depends on the field, the x-coordinates xs +-- of the shares and the x-coordinate x_r of the recombination point. +_recombinationVector :: FiniteField -> [Integer] -> Integer -> [Integer] +_recombinationVector field xs x_r = map coefs_div (zip [0..] xs) + where + coefs_div (i, x_i) = let (cf_n, cf_d) = coefs i x_i + in cf_n `div` cf_d + coefs i x_i = foldr (\(j, x_j) (coef_n, coef_d) -> + if j /= i + then (coef_n * (x_r-x_j), coef_d * (x_i-x_j)) + else (coef_n, coef_d)) (1,1) (zip [0..] xs) + +-- | Recombine shares given by points into secrets. +-- +-- Recombination is done for x-coordinates x_rs. +recombine :: FiniteField -> [IdSharesPair] -> [FiniteField] +recombine field points = + let (xs, shares) = unzip points + vector = _recombinationVector field xs 0 + p = modulus $ meta field + in map (\share_i -> field{value = (sum share_i vector) `mod` p}) (transpose shares) + where + sum share_i vector = foldr (\(i, s) -> (+) (s * (vector !! i) )) 0 (zip [0..] share_i)
+ app/Types.hs view
@@ -0,0 +1,36 @@+module Types where + +import Control.Concurrent +import Network.Socket +import qualified Data.Map.Strict as Map +import Control.Monad.State +import Parser +import qualified Data.ByteString as BS +import System.Log.Logger +import System.Random +import Data.Time.Clock + +-- read dictionary, key = pc, value = mvar bytestring +type Dict = Map.Map Int (MVar BS.ByteString) +-- pid, (socket send to peer (nothing if self), read value from mvar in dict) +data Party = Party {pid :: Integer, host :: String, port :: Integer, outChan :: Chan BS.ByteString, sock :: Maybe Socket, dict :: MVar Dict, nbytesSent :: MVar Int} + +data Barrier = Barrier { count :: MVar Int, signal :: MVar () } + +-- state transformer environment +data Env = Env { + parties :: [Party], + pc :: Int, + options :: Options, + forkIOBarrier :: Barrier, + gen :: StdGen, + startTime :: UTCTime +} + +type SIO a = StateT Env IO a + +runSIO :: SIO a -> Env -> IO a +runSIO = evalStateT + +logging :: Priority -> String -> IO () +logging prio str = logM rootLoggerName prio str
+ demos/Id3gini.hs view
@@ -0,0 +1,194 @@+{- +Demo decision tree learning using ID3. + +This demo implements Protocol 4.1 from the paper 'Practical Secure Decision +Tree Learning in a Teletreatment Application' by Sebastiaan de Hoogh, Berry +Schoenmakers, Ping Chen, and Harm op den Akker, which appeared at the 18th +International Conference on Financial Cryptography and Data Security (FC 2014), +LNCS 8437, pp. 179-194, Springer. +See https://doi.org/10.1007/978-3-662-45472-5_12 (or, +see https://fc14.ifca.ai/papers/fc14_submission_103.pdf or, +see https://www.researchgate.net/publication/295148009). + +ID3 is a recursive algorithm for generating decision trees from a database +of samples (or, transactions). The first or last attribute of each sample +is assumed to be the class attribute, according to which the samples are +classified. Gini impurity is used to determine the best split. See also +https://en.wikipedia.org/wiki/ID3_algorithm. + +The samples are assumed to be secret, while the resulting decision tree is +public. All calculations are performed using secure integer arithmetic only. + +The demo includes the following datasets (datasets 1-4 are used in the paper): + + 0=tennis: classic textbook example + 1=balance-scale: balance scale weight & distance database + 2=car: car evaluation database + 3=SPECT: Single Proton Emission Computed Tomography train+test heart images + 4=KRKPA7: King+Rook versus King+Pawn-on-A7 chess endgame + 5=tic-tac-toe: Tic-Tac-Toe endgame + 6=house-votes-84: 1984 US congressional voting records + +The numbers 0-6 can be used with the command line option -i of the demo. + +Three command line options are provided for controlling accuracy: + + -l L, --bit-length: overrides the preset bit length for a dataset + -e E, --epsilon: minimum number of samples E required for attribute nodes, + represented as a fraction of all samples, 0.0<=E<=1.0 + -a A, --alpha: scale factor A to avoid division by zero when calculating + Gini impurities, basically, by adding 1/A to denominators, A>=1 + +Setting E=1.0 yields a trivial tree consisting of a single leaf node, while +setting E=0.0 yields a large (overfitted) tree. Default value E=0.05 yields +trees of reasonable complexity. Default value A=8 is sufficiently large for +most datasets. Note that if A is increased, L should be increased accordingly. + +Finally, the command line option --parallel-subtrees can be used to let the +computations of the subtrees of an attribute node be done in parallel. The +default setting is to compute the subtrees one after another (in series). +The increase in the level of parallelism, however, comes at the cost of +a larger memory footprint. + +Interestingly, one will see that the order in which the nodes are added to +the tree will change if the --parallel-subtrees option is used. The resulting +tree is still the same, however. Of course, this only happens if the hMPC +program is actually run with multiple parties (or, if the -M1 option is used). +-} +module Id3gini (main) where + +import Control.Monad.State (liftIO) +import Control.Monad (forM) +import Data.List (transpose, isPrefixOf) +import Data.List.Split (splitOn) +import Data.Char (toLower) +import SecTypes (secIntGen, SecureTypes) +import System.Log.Logger (infoM, rootLoggerName) +import Text.Printf (printf) +import Options.Applicative +import Types +import Runtime as Mpc +import qualified Data.Set as Set + + +data Tree = Leaf Int | Node Int [Tree] deriving (Show) + +data Env = Env { + ms :: [[[SIO SecureTypes]]], + c :: Int, + opts :: Options +} + +data Options = Options + { dataset :: Int, bitLength :: Maybe Int, epsilon :: Float, + alpha :: Int, parallelSubtrees :: Bool, noPrettyTree :: Bool } + + +id3 :: Id3gini.Env -> Set.Set Int -> [SIO SecureTypes] -> SIO Tree +id3 env r vt = do + sizes <- mapM (return <$> (Mpc.inProd vt)) ((ms env) !! (c env)) + (i , mx) <- Mpc.argmax sizes + sizeT <- return <$> Mpc.ssum sizes + let stop = (sizeT .<= (fromIntegral . floor) ((epsilon $ opts env) * (fromIntegral $ length vt))) + (mx .== sizeT) + isZero <- Mpc.await =<< Mpc.isZeroPublic stop + if not $ (not . null) r && isZero + then do + i <- Mpc.await =<< Mpc.output i + liftIO $ infoM rootLoggerName ("Leaf node label " ++ show i) + return $ Leaf $ fromInteger i + else do + vt_sc <- mapM (Mpc.schurProd vt) ((ms env) !! (c env)) + gains <- forM (Set.toList r) $ \a -> + Mpc.matrixProd (ms env !! a) vt_sc True >>= gi (alpha $ opts env) + k <- Mpc.await =<< Mpc.output =<< fst <$> (Mpc.argmaxfunc gains secureFraction) + let a = (Set.toList r) !! fromInteger k + vt_sa <- mapM (Mpc.schurProd vt) ((ms env) !! a) + liftIO $ infoM rootLoggerName ("Attribute node " ++ show a) + subtrees <- if parallelSubtrees $ opts env + then mapM (async . id3 env (Set.difference r (Set.fromList [a]))) vt_sa + >>= mapM Mpc.await + else mapM (id3 env (Set.difference r (Set.fromList [a]))) vt_sa + + return $ Node a subtrees + +gi :: Int -> [[SIO SecureTypes]] -> SIO [SIO SecureTypes] +gi alpha x = do + y <- forM x $ \a -> return <$> ((fromIntegral alpha) * (Mpc.ssum a) + 1) + d <- return <$> Mpc.sproduct y + let g = Mpc.inProd (zipWith Mpc.inProd x x) (map (1 /) y) + return [d * g, d] + +secureFraction :: [SIO SecureTypes] -> [SIO SecureTypes] -> SIO SecureTypes +secureFraction [n1, d1] [n2, d2] = Mpc.inProd [n1, negate d1] [d2, n2] .< 0 + + +depth :: Tree -> Int +depth (Leaf _) = 0 +depth (Node _ subtrees) = 1 + maximum (map depth subtrees) + +size :: Tree -> Int +size (Leaf _) = 1 +size (Node _ subtrees) = 1 + sum (map size subtrees) + +pretty :: String -> Tree -> [String] -> [[String]] -> Int -> String +pretty prefix (Leaf a) names ranges c = (ranges !! c) !! a +pretty prefix (Node a subtrees) names ranges c = + let subtreeStrings = map (\(s, t) -> + printf "\n%s%s == %s: %s" prefix (names !! a) s (pretty ("| " ++ prefix) t names ranges c)) + (zip (ranges !! a) subtrees) + in concat subtreeStrings + +settings = [("tennis", 32), ("balance-scale", 77), ("car", 95), + ("SPECT", 42), ("KRKPA7", 69), ("tic-tac-toe", 75), ("house-votes-84", 62)] + +parser :: Parser Options +parser = Options + <$> option auto + ( short 'i' <> long "dataset" <> showDefault <> value 0 <> metavar "I" + <> help ("dataset 0=tennis (default), 1=balance-scale, 2=car, \ + \3=SPECT, 4=KRKPA7, 5=tic-tac-toe, 6=house-votes-84")) + <*> optional ( option auto + ( short 'l' <> long "bit-length" <> metavar "L" + <> help "override preset bit length for dataset")) + <*> option auto + ( short 'e' <> long "epsilon" <> showDefault <> value 0.05 <> metavar "E" + <> help "minimum fraction E of samples for a split, 0.0<=E<=1.0") + <*> option auto + ( short 'a' <> long "alpha" <> showDefault <> value 8 <> metavar "A" + <> help "scale factor A to prevent division by zero, A>=1") + <*> switch + ( long "parallel-subtrees" + <> help "process subtrees in parallel (rather than in series)" ) + <*> switch + ( long "no-pretty-tree" + <> help "print raw flat tree instead of pretty tree" ) + +main :: IO () +main = Mpc.runMpcWithArgs parser $ \opts -> do + let (name, bitLengthOpts) = settings !! (dataset opts) + secInt <- secIntGen (maybe bitLengthOpts id (bitLength opts)) + + content <- liftIO $ readFile $ "demos/data/id3/" ++ name ++ ".csv" + let (attrNames, transactions) = splitAt 1 $ map (splitOn ",") $ lines content + columns = transpose transactions + attrRanges = map (Set.toList . Set.fromList) columns + (n, d) = (length transactions, length $ head $ transactions) + checkPrefix prefix len = if isPrefixOf "class" prefix then 0 else len - 1 + vars2 = Id3gini.Env { + -- one-hot encoding of attributes: + ms = (map (\(attrRange, col) -> + map (\attr -> + map (\elem -> (secInt . fromIntegral . fromEnum) (attr == elem)) + col) attrRange) (zip attrRanges columns)), + c = checkPrefix (map toLower (head $ head attrNames)) (length $ head attrNames), + opts = opts } + vt = replicate n (secInt 1) + r = Set.difference (Set.fromList [0..(d - 1)]) (Set.fromList [c vars2]) + + liftIO $ putStrLn $ show (parallelSubtrees opts) + liftIO $ printf "dataset: %s with %d samples and %d attributes\n" name n (d-1) + tree <- Mpc.runSession $ id3 vars2 r vt + liftIO $ printf "Decision tree of depth %d and size %d: " (depth tree) (size tree) + liftIO $ putStrLn $ if noPrettyTree opts + then show tree + else pretty "if " tree (head attrNames) attrRanges (c vars2)
+ hMPC.cabal view
@@ -0,0 +1,142 @@+cabal-version: 1.12 ++-- This file has been generated from package.yaml by hpack version 0.35.1.+--+-- see: https://github.com/sol/hpack++name: hMPC+version: 0.1.0.0+synopsis: Multiparty Computation in Haskell+description: hMPC is a Haskell package for secure multiparty computation (MPC).+ .+ hMPC provides a runtime for performing computations on secret-shared values,+ where parties interact by exchanging messages via peer-to-peer connections.+ The hMPC protocols are based on Shamir's threshold secret sharing scheme+ and withstand passive adversaries controlling less than half of the parties.+ .+ Secure integer arithmetic is supported for parameterized+ number ranges, including support for comparison operations.+ Secure finite field arithmetic is supported.+ .+ The above operations are all available via Haskell's operator overloading.+ .+ Secure drop-in replacements for lots of Haskell built-in functions, such as+ 'all', 'sum', 'min', 'max' are provided, mimicking the Haskell+ APIs as much as possible. Further operations for container datatypes holding+ secret-shared data items are provided as well (e.g., matrix-vector operations+ like secure dot products).+category: Cryptography+homepage: https://github.com/nickvgils/hMPC#readme+bug-reports: https://github.com/nickvgils/hMPC/issues+author: Nick van Gils+maintainer: nick.vangils@hotmail.com+copyright: 2024 Nick van Gils+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/nickvgils/hMPC++library+ exposed-modules:+ Shamir+ FinFields+ Runtime+ SecTypes+ Types+ Asyncoro+ Parser+ Hgmp+ other-modules:+ MpcTools+ Paths_hMPC+ hs-source-dirs:+ app+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , binary >=0.8.8 && <0.9+ , bytestring >=0.10.12 && <0.11+ , cereal >=0.5.8 && <0.6+ , containers >=0.6.4 && <0.7+ , hashable >=1.3.5.0 && <1.5+ , hgmp >=0.1.2 && <0.2+ , hslogger >=1.3.1 && <1.4+ , lens >=5.0.1 && <5.3+ , mtl >=2.2.2 && <2.3+ , network >=3.1.2.7 && <3.2+ , optparse-applicative >=0.16.1.0 && <0.19+ , process >=1.6.13 && <1.7+ , random >=1.2.1 && <1.3+ , split >=0.2.3.4 && <0.3+ , stm >=2.5.0 && <2.6+ , time >=1.9.3 && <1.10+ , vector >=0.12.3.1 && <0.14+ default-language: Haskell2010++executable id3gini+ main-is: Id3gini.hs+ other-modules:+ Paths_hMPC+ hs-source-dirs:+ demos+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -main-is Id3gini -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , binary >=0.8.8 && <0.9+ , bytestring >=0.10.12 && <0.11+ , cereal >=0.5.8 && <0.6+ , containers >=0.6.4 && <0.7+ , hMPC+ , hashable >=1.3.5.0 && <1.5+ , hgmp >=0.1.2 && <0.2+ , hslogger >=1.3.1 && <1.4+ , lens >=5.0.1 && <5.3+ , mtl >=2.2.2 && <2.3+ , network >=3.1.2.7 && <3.2+ , optparse-applicative >=0.16.1.0 && <0.19+ , process >=1.6.13 && <1.7+ , random >=1.2.1 && <1.3+ , split >=0.2.3.4 && <0.3+ , stm >=2.5.0 && <2.6+ , time >=1.9.3 && <1.10+ , vector >=0.12.3.1 && <0.14+ default-language: Haskell2010++test-suite test-hMPC+ type: exitcode-stdio-1.0+ main-is: TestMain.hs+ other-modules:+ RuntimeTest+ ShamirTest+ Paths_hMPC+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit >=1.6.2.0+ , base >=4.7 && <5+ , binary >=0.8.8 && <0.9+ , bytestring >=0.10.12 && <0.11+ , cereal >=0.5.8 && <0.6+ , containers >=0.6.4 && <0.7+ , hMPC+ , hashable >=1.3.5.0 && <1.5+ , hgmp >=0.1.2 && <0.2+ , hslogger >=1.3.1 && <1.4+ , lens >=5.0.1 && <5.3+ , mtl >=2.2.2 && <2.3+ , network >=3.1.2.7 && <3.2+ , optparse-applicative >=0.16.1.0 && <0.19+ , process >=1.6.13 && <1.7+ , random >=1.2.1 && <1.3+ , split >=0.2.3.4 && <0.3+ , stm >=2.5.0 && <2.6+ , time >=1.9.3 && <1.10+ , vector >=0.12.3.1 && <0.14+ default-language: Haskell2010
+ test/RuntimeTest.hs view
@@ -0,0 +1,52 @@+module RuntimeTest(tests) where + +import Test.HUnit +-- import Control.Concurrent.MVar + +-- import Shamir +import Runtime +-- import SecTypes +-- import FinFields +import Control.Monad.State +-- import Data.Hashable + + + +runtimeFunctions = runMpc $ do + secInt <- secIntGen 64 + let secFld = secFldGen 101 + (af, bf) = (secFld 6, secFld 6) + (a, b) = (secInt (14), secInt 14) + (v1, v2) = (map secInt [1,8,3,10,2,7], map secInt [4,5,6]) + (amat, bmat) = ([v1,v2], (map . map) secInt [[10,11], [20,21], [30,31]]) + + n1 = 5 + n2 = 3 + k = 11 + + runSession $ do + -- out <- Runtime.sisZeroPublic a + -- out <- await =<< Runtime.output (a .<= b) + out <- Runtime.await =<< Runtime.output (fst =<< argmax v1) + -- out <- Runtime.output $ smaximum v1 + -- out <- Runtime.output =<< ifElseList (a .< b) [b] [a] + -- out <- Runtime.output $ Runtime.ssignum True False a + -- out <- Runtime.output . concat =<< Runtime.matrixProd amat bmat False + -- out <- Runtime.output $ Runtime.inProd v1 v2 + -- out <- Runtime.output =<< Runtime.schurProd v1 v2 + -- inp <- Runtime.input v1 + -- out <- Runtime.output (inp !! 0) + -- out <- Runtime.output $ Runtime.sproduct v1 + -- out <- Runtime.output =<< Runtime.randomBits a 5 True + -- out <- Runtime.output (af .== bf) + -- out <- Runtime.output (a / b) + -- out <- Runtime.output $ recip a + -- out <- Runtime.output ((a *a) * (a * a)) + -- out <- Runtime.output (a .^ k) + liftIO $ putStrLn $ "outcome var " ++ show k ++ " : " ++ show out + return () + +tests = TestList + [ + TestLabel "runtime12" $ TestCase (runtimeFunctions) + ]
+ test/ShamirTest.hs view
@@ -0,0 +1,26 @@+module ShamirTest(tests) where + +import Test.HUnit +import Control.Monad +import System.Random + +import Shamir +import FinFields + +secretsharing = do + let field = gf 19 + forM_ [0..7] $ \t -> do + g <- newStdGen + -- putStrLn $ show $ take 5 $ randomRs (0, 1) g + -- let m = 2 * t + 1 + -- let a = map (\i -> field{value = i}) [0..t] + -- let shares = fst $ randomSplit (head a) a t m g + -- putStrLn $ show shares + -- putStrLn $ show (recombine field (zip [1..] shares)) + assertEqual "hooi" [1] [1] + -- assertEqual "t=0,m=1" [0..t] (recombine field (zip [1..] shares)) + + +tests = TestList + [ TestLabel "ado1" $ TestCase (secretsharing) + ]
+ test/TestMain.hs view
@@ -0,0 +1,17 @@+module Main (main) where + +import ShamirTest +import RuntimeTest +import Test.HUnit + +main :: IO () +main = do + runTestTT allTests + return () + +allTests :: Test +allTests = TestList + [ + TestLabel "ShamirThresha" ShamirTest.tests, + TestLabel "Runtime" RuntimeTest.tests + ]