diff --git a/apps/Crypto/Lol/Applications/KeyHomomorphicPRF.hs b/apps/Crypto/Lol/Applications/KeyHomomorphicPRF.hs new file mode 100644 index 00000000..793c4264 --- /dev/null +++ b/apps/Crypto/Lol/Applications/KeyHomomorphicPRF.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE GADTs, NoImplicitPrelude #-} + +-- Ring-LWE key-homomorphic PRF from [BP14]. + +module Crypto.Lol.Applications.KeyHomomorphicPRF +( augmentBS +, augmentVector +, computePRF +, flipBit +, FullTree(..) +) where + +import Control.Applicative + +import Crypto.Lol + +-- | Unsafe full tree. +data FullTree l v where + Leaf :: l -> v -> FullTree l v + Internal :: Int -> Int -> v -> + FullTree l v -> + FullTree l v -> + FullTree l v + +-- | Returns the vertex type attached to the FullTree. +rootValue :: FullTree l v -> v +rootValue (Leaf _ v) = v +rootValue (Internal _ _ v _ _) = v + +-- | Augments the leaves of the FullTree with Bool values. +augmentBS :: FullTree () () -> -- ^ Topology of T + [Bool] -> -- ^ Bitstring x of size |T| + FullTree Bool () -- ^ Bit on each leaf of T +augmentBS (Leaf _ _) [bit] = Leaf bit () +augmentBS (Internal ls rs _ left right) bits = + let (leftBits, rightBits) = splitAt ls bits + in Internal ls rs () (augmentBS left leftBits) (augmentBS right rightBits) + +-- | Augments the nodes of the FullTree with Matrix values. +-- | Note: The base vectors must have the same number +-- | of entries as the gadget with which these vectors are decomposed. +augmentVector :: Decompose gad a => + Matrix a -> -- ^ Base vector a0 + Matrix a -> -- ^ Base vector a1 + FullTree Bool () -> -- ^ Bit on each leaf of T + Tagged gad (FullTree Bool (Matrix a)) -- ^ Matrix at nodes of T +augmentVector a0 a1 (Leaf b _) = do + return $ Leaf b $ if b then a1 else a0 +augmentVector a0 a1 (Internal nl nr _ l r) = do + l' <- augmentVector a0 a1 l + r' <- augmentVector a0 a1 r + c <- combineVectors (rootValue l') (rootValue r') + return $ Internal nl nr c l' r' + +-- | Equation (2.10) in [BP14]. +computePRF :: (Ring a, Ring b, Rescale a b) => + FullTree l (Matrix a) -> -- ^ Matrix at nodes of T + a -> -- ^ secret s + Matrix b -- ^ Final result +computePRF t s = rescale . (*s) <$> rootValue t + +-- | Flip the boolean value at a chosen leaf. +-- | Updates the affected matrices at each node. +flipBit :: Decompose gad a => + Matrix a -> -- ^ Base vector a0 + Matrix a -> -- ^ Base vector a1 + Int -> -- ^ which bit to flip (1-indexed) + FullTree Bool (Matrix a) -> -- ^ Matrix at nodes of T + Tagged gad (FullTree Bool (Matrix a)) -- ^ Matrix at nodes of T +flipBit a0 a1 _ (Leaf b _) = do + return $ Leaf (not b) $ if b then a0 else a1 +flipBit a0 a1 n (Internal nl nr _ l r) + | (n > nl) = do + r' <- flipBit a0 a1 (n - nl) r + c <- combineVectors (rootValue l) (rootValue r') + return $ Internal nl nr c l r' + | otherwise = do + l' <- flipBit a0 a1 n l + c <- combineVectors (rootValue l') (rootValue r) + return $ Internal nl nr c l' r + +-- | Multiply two matrices as given in the +-- | "otherwise" case of Equation (2.9) in [BP14]. +combineVectors :: Decompose gad a => + Matrix a -> + Matrix a -> + Tagged gad (Matrix a) +combineVectors l tr = do + r <- decomposeMatrix tr + return $ l * (fmap reduce r) diff --git a/apps/examples/KeyHomomorphicPRF/SimplePRF.hs b/apps/examples/KeyHomomorphicPRF/SimplePRF.hs new file mode 100644 index 00000000..39b44883 --- /dev/null +++ b/apps/examples/KeyHomomorphicPRF/SimplePRF.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds, NoImplicitPrelude #-} + +import Crypto.Lol +import Crypto.Lol.Applications.KeyHomomorphicPRF + +import MathObj.Matrix + +main :: IO () +main = do + let (actual1, actual2) = untag $ testComputePRF + expected1 = fromList 1 4 (fmap fromInteger [2,2,4,2]) + expected2 = fromList 1 4 (fmap fromInteger [2,2,2,2]) + + print $ "Test1: " ++ (show $ actual1 == expected1) + print $ "Test2: " ++ (show $ actual2 == expected2) + +-- | Returns a tagged tuple of matrices. +-- | The first matrix is the result of computePRF after the initial augmentation. +-- | The second matrix is the result of computePRF after flipping a bit. +testComputePRF :: Tagged (BaseBGad 2) + (Matrix (ZqBasic 5 Int), (Matrix (ZqBasic 5 Int))) +testComputePRF = do + -- Define the base vectors and the desired ring. + -- The compiler will infer the ring after it is defined once. + let a0 = fromList 1 4 (fmap fromInteger [7,12,3,7] :: [ZqBasic 13 Int]) + a1 = fromList 1 4 (fmap fromInteger [2,11,6,10]) + -- Define the topology of the full tree. + -- Note that, in this case, |t| = 4. + t = Internal 3 1 () + (Internal 1 2 () + (Leaf () ()) + (Internal 1 1 () + (Leaf () ()) + (Leaf () ()) + ) + ) + (Leaf () ()) + -- Define a bitstring of length |t|. + bits = [False, False, True, False] + -- Define the secret s. + s = fromInteger 9 + -- Augment the tree with bits and then the base vectors. + at <- augmentVector a0 a1 $ augmentBS t bits + -- Flip the bit of a leaf on the tree and recalculate + -- the vectors of the affected nodes. + ft <- flipBit a0 a1 2 at + return $ (computePRF at s, computePRF ft s) diff --git a/apps/lol-apps.cabal b/apps/lol-apps.cabal index d1898c2c..907823b3 100644 --- a/apps/lol-apps.cabal +++ b/apps/lol-apps.cabal @@ -61,6 +61,7 @@ library ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 exposed-modules: + Crypto.Lol.Applications.KeyHomomorphicPRF Crypto.Lol.Applications.SymmSHE build-depends: @@ -123,6 +124,20 @@ Benchmark bench-apps vector, repa +executable simplePRF + hs-source-dirs: examples/KeyHomomorphicPRF + default-language: Haskell2010 + main-is: SimplePRF.hs + + ghc-options: -threaded -rtsopts + + build-depends: + arithmoi, + base, + lol, + lol-apps, + numeric-prelude + executable simpleSHE hs-source-dirs: examples/SymmSHE, utils default-language: Haskell2010 @@ -136,4 +151,4 @@ executable simpleSHE lol, lol-apps, MonadRandom, - numeric-prelude \ No newline at end of file + numeric-prelude