Key-homomorphic PRF merge

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)

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)

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
+    numeric-prelude