diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -3,7 +3,18 @@ 0.2.0.0 ---- + * Added [BPF14] key-homomorphic PRF. + * Added homomorphic evaluation of PRF. + * Simpler benchmarks and tests. + * SHE: Made hints for key switching and ring tunneling explicit. + * SHE: Protocol buffer formats for tunneling, key-switch hints, secret keys, etc. + Note that this provides an easy way to save expensive precomputation. See + the HomomPRF example for more details. + +0.1.1.0 +---- * Updated documentation with MathJax + * Added 0.1.0.0 ----- diff --git a/Crypto/Lol/Applications/HomomPRF.hs b/Crypto/Lol/Applications/HomomPRF.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Applications/HomomPRF.hs @@ -0,0 +1,530 @@ +{-| +Module : Crypto.Lol.Applications.HomomPRF +Description : Homomorphic evaluation of the PRF from . +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + +Homomorphic evaluation of the PRF from . +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Crypto.Lol.Applications.HomomPRF +(homomPRF, homomPRFM +,RoundHints(..), roundHints +,TunnelInfoChain(..), tunnelInfoChain +,EvalHints(..) +,MultiTunnelCtx, ZqUp, ZqDown +,TwoOf +,Tunnel, PTRound, ZqResult +,PTRings, PTTunnel(..), TunnelFuncs(..)) where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.Except +import Control.Monad.Random hiding (fromList) +import Control.Monad.Reader +import Control.Monad.State + +import Crypto.Lol +import Crypto.Lol.Applications.KeyHomomorphicPRF +import Crypto.Lol.Reflects +import Crypto.Lol.Types + +import Crypto.Lol.Applications.SymmSHE +import Crypto.Lol.Types.ZPP +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Types.Proto +import qualified Crypto.Proto.HomomPRF.LinearFuncChain as P +import qualified Crypto.Proto.HomomPRF.RoundHintChain as P +import qualified Crypto.Proto.HomomPRF.TunnelInfoChain as P +import qualified Crypto.Proto.Lol.RqProduct as P +import qualified Crypto.Proto.SHE.TunnelInfo as P + +import Data.List.Split (chunksOf) +import Data.Promotion.Prelude + +import GHC.TypeLits hiding (type (*)) + +import MathObj.Matrix (columns) + +import Data.Sequence (empty, (<|), ViewL(..), viewl) + +-- | The element before @zq@ in type list @zqs@. +type ZqUp zq zqs = NextListElt zq (Reverse zqs) +-- | The element after @zq@ in type list @zqs@. +type ZqDown zq zqs = NextListElt zq zqs + +type family NextListElt (x :: k) (xs :: [k]) :: k where + NextListElt x (x ': y ': ys) = y + NextListElt x '[x] = TypeError ('Text "There is no 'next'/'prev' list element for " ':<>: 'ShowType x ':<>: 'Text "!" ':$$: + 'Text "Try adding more moduli to the ciphertext modulus list") + NextListElt x (y ': ys) = NextListElt x ys + NextListElt x '[] = TypeError ('Text "Could not find type " ':<>: 'ShowType x ':<>: 'Text " in the list." ':$$: + 'Text "You must use parameters that are in the type lists!") + +-- | The offline data needed for homomorphic PRF evaluation. +data EvalHints t rngs z zp zq zqs gad where + Hints :: (UnPP (CharOf zp) ~ '(Prime2, e)) + => TunnelInfoChain gad t rngs zp (ZqUp zq zqs) + -> RoundHints t (Fst (Last rngs)) (Snd (Last rngs)) z e zp (ZqDown zq zqs) zqs gad + -> EvalHints t rngs z zp zq zqs gad + +instance (UnPP (CharOf zp) ~ '(Prime2, e), + NFData (TunnelInfoChain gad t rngs zp (ZqUp zq zqs)), + NFData (RoundHints t (Fst (Last rngs)) (Snd (Last rngs)) z e zp (ZqDown zq zqs) zqs gad)) + => NFData (EvalHints t rngs z zp zq zqs gad) where + rnf (Hints t r) = rnf t `seq` rnf r + +-- | Monadic version of 'homomPRF' +homomPRFM :: + (MonadReader (EvalHints t rngs z zp zq zqs gad) mon, + MonadState (PRFState (Cyc t r zp) (Cyc t r (TwoOf zp))) mon, + MulPublicCtx t r r' zp zq, + MultiTunnelCtx rngs r r' s s' t z zp zq gad zqs, + PTRound t s s' e zp (ZqDown zq zqs) z gad zqs) + => CT r zp (Cyc t r' zq) -- encryption of PRF secret + -> Int -- PRF input + -> mon (CT s (TwoOf zp) (Cyc t s' (ZqResult e (ZqDown zq zqs) zqs))) +homomPRFM ct x = do + hints <- ask + state $ homomPRF' hints ct x + +-- | Evaluates the PRF family indexed by the encrypted secret on the input, +-- relative to some PRF state. Note that the algorithm in +-- outputs a +-- /vector/; this function only outputs the encryption of the first coefficient +-- of that vector. +homomPRF :: (MulPublicCtx t r r' zp zq, + MultiTunnelCtx rngs r r' s s' t z zp zq gad zqs, + PTRound t s s' e zp (ZqDown zq zqs) z gad zqs) + => EvalHints t rngs z zp zq zqs gad + -> CT r zp (Cyc t r' zq) + -> Int + -> PRFState (Cyc t r zp) (Cyc t r (TwoOf zp)) + -> CT s (TwoOf zp) (Cyc t s' (ZqResult e (ZqDown zq zqs) zqs)) +homomPRF hs ct x = fst . homomPRF' hs ct x + +homomPRF' :: forall t e r s r' s' rngs z zp zq zqs gad . + (MulPublicCtx t r r' zp zq, + MultiTunnelCtx rngs r r' s s' t z zp zq gad zqs, + PTRound t s s' e zp (ZqDown zq zqs) z gad zqs) + => EvalHints t rngs z zp zq zqs gad + -> CT r zp (Cyc t r' zq) + -> Int + -> PRFState (Cyc t r zp) (Cyc t r (TwoOf zp)) + -> (CT s (TwoOf zp) (Cyc t s' (ZqResult e (ZqDown zq zqs) zqs)), + PRFState (Cyc t r zp) (Cyc t r (TwoOf zp))) +homomPRF' (Hints tHints rHints) ct x st = + let (atx,st') = evalTree x st + firstElt = head $ head $ columns atx + ctMatrix1 = mulPublic firstElt ct + ctMatrix2 = tunnel (Proxy::Proxy zqs) tHints ctMatrix1 + in (ptRound rHints ctMatrix2, st') + +-- | \(\Z_2\) for ZqBasic with a 'PrimePower' modulus +type family TwoOf (a :: k) :: k +type instance TwoOf (ZqBasic (q :: PrimePower) i) = ZqBasic PP2 i + +-- For rounding +type family Div2 (a :: k) :: k +type instance Div2 (ZqBasic q i) = ZqBasic (Div2 q) i +type instance Div2 (pp :: PrimePower) = Head (UnF (PpToF pp / F2)) + +-- type-restricted versions of rescaleLinearCT +roundCTUp :: (RescaleCyc (Cyc t) zq (ZqUp zq zqs), ToSDCtx t m' zp zq) + => Proxy zqs -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' (ZqUp zq zqs)) +roundCTUp _ = rescaleLinearCT + +roundCTDown :: (RescaleCyc (Cyc t) zq (ZqDown zq zqs), ToSDCtx t m' zp zq) + => Proxy zqs -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' (ZqDown zq zqs)) +roundCTDown _ = rescaleLinearCT + + + + + + + + + + + + + + + + + + +-- | Quadratic key switch hints for the rounding phase of PRF evaluation. +data RoundHints t m m' z e zp zq zqs gad where + RHNil :: RoundHints t m m' z e zp zq zqs gad + RHCons :: KSQuadCircHint gad (Cyc t m' (ZqUp zq zqs)) + -> RoundHints t m m' z e (Div2 zp) (ZqDown zq zqs) zqs gad + -> RoundHints t m m' z ('S e) zp zq zqs gad + +instance NFData (RoundHints t m m' z P1 zp zq zqs gad) where + rnf RHNil = () + +instance (NFData (KSQuadCircHint gad (Cyc t m' (ZqUp zq zqs))), + NFData (RoundHints t m m' z e (Div2 zp) (ZqDown zq zqs) zqs gad)) + => NFData (RoundHints t m m' z ('S e) zp zq zqs gad) where + rnf (RHCons h hs) = rnf h `seq` rnf hs + +instance Protoable (RoundHints t m m' z P1 zp zq zqs gad) where + type ProtoType (RoundHints t m m' z P1 zp zq zqs gad) = P.RoundHintChain + toProto RHNil = P.RoundHintChain empty + fromProto (P.RoundHintChain xs) | xs == empty = return RHNil + fromProto _ = throwError $ "Got non-empty chain on fromProto for RoundHints" + +instance (Protoable (KSQuadCircHint gad (Cyc t m' (ZqUp zq zqs))), + Protoable (RoundHints t m m' z e (Div2 zp) (ZqDown zq zqs) zqs gad), + ProtoType (RoundHints t m m' z e (Div2 zp) (ZqDown zq zqs) zqs gad) ~ P.RoundHintChain) + => Protoable (RoundHints t m m' z ('S e) zp zq zqs gad) where + type ProtoType (RoundHints t m m' z ('S e) zp zq zqs gad) = P.RoundHintChain + toProto (RHCons f fs) = + let f' = toProto f + (P.RoundHintChain fs') = toProto fs + in P.RoundHintChain $ f' <| fs' + fromProto (P.RoundHintChain fs) = do + when (fs == empty) $ throwError "fromProto RoundHints: expected at least one element" + let (a :< as) = viewl fs + b <- fromProto a + bs <- fromProto $ P.RoundHintChain as + return $ RHCons b bs + +-- | Functions related to homomorphically rounding from 2^k to 2 +class (UnPP (CharOf zp) ~ '(Prime2,e)) => PTRound t m m' e zp zq z gad zqs where + type ZqResult e zq (zqs :: [*]) + + -- | Generate hints for rounding from \(R_p=R_{2^k}\) to \(R_2\) + roundHints :: (MonadRandom rnd) + => SK (Cyc t m' z) -> rnd (RoundHints t m m' z e zp zq zqs gad) + + -- round(q/p*x) (with "towards infinity tiebreaking") + -- = msb(x+q/4) = floor((x+q/4)/(q/2)) + -- | Round coeffs in CRT slots near 0 to 0 and near q/2 to 1, with a short-cut + -- on the first level of the rounding tree. + ptRound :: RoundHints t m m' z e zp zq zqs gad -> CT m zp (Cyc t m' zq) -> CT m (TwoOf zp) (Cyc t m' (ZqResult e zq zqs)) + + -- | All levels other than the first level of the rounding tree. + ptRoundInternal :: RoundHints t m m' z e zp zq zqs gad -> [CT m zp (Cyc t m' zq)] -> CT m (TwoOf zp) (Cyc t m' (ZqResult e zq zqs)) + +instance PTRound t m m' P1 (ZqBasic PP2 i) zq z gad zqs where + type ZqResult P1 zq zqs = zq + + roundHints _ = return RHNil + + ptRound RHNil x = x + + ptRoundInternal RHNil [x] = x + +instance (UnPP p ~ '(Prime2, 'S e), -- superclass constraint + zqup ~ ZqUp zq zqs, zq' ~ ZqDown zq zqs, zp ~ ZqBasic p i, zp' ~ Div2 zp, -- convenience synonyms + AddPublicCtx t m m' zp zq, AddPublicCtx t m m' zp zq', -- addPublic + KeySwitchCtx gad t m' zp zq zqup, KSHintCtx gad t m' z zqup, -- for quadratic key switch + Reflects p Int, -- value + Ring (CT m zp (Cyc t m' zq)), -- (*) + RescaleCyc (Cyc t) zq zq', ToSDCtx t m' zp zq, -- rescaleLinearCT + ModSwitchPTCtx t m' zp zp' zq', -- modSwitchPT + PTRound t m m' e zp' zq' z gad zqs, -- recursive call + Protoable (KSQuadCircHint gad (Cyc t m' (ZqUp zq zqs)))) -- toProto + => PTRound t m m' ('S e) (ZqBasic p i) (zq :: *) z gad zqs where + type ZqResult ('S e) zq zqs = ZqResult e (ZqDown zq zqs) zqs + + roundHints sk = do + ksq <- ksQuadCircHint sk + rest <- roundHints sk + return $ RHCons ksq rest + + ptRound (RHCons ksqHint rest) x = + let x' = addPublic one x + xprod = rescaleLinearCT $ keySwitchQuadCirc ksqHint $ x*x' + p = proxy value (Proxy::Proxy p) + xs = map (\y->modSwitchPT $ addPublic (fromInteger $ y*(-y+1)) xprod) [1..] :: [CT m zp' (Cyc t m' zq')] + in ptRoundInternal rest $ take (p `div` 4) xs + + ptRoundInternal (RHCons ksqHint rest) (xs :: [CT m (ZqBasic p i) (Cyc t m' zq)]) = + let pairs = chunksOf 2 xs + go [a,b] = modSwitchPT $ rescaleLinearCT $ keySwitchQuadCirc ksqHint $ a*b :: CT m zp' (Cyc t m' zq') + in ptRoundInternal rest (map go pairs) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- For (homomorphic) tunneling + +-- | Sequence of 'TunnelInfo' for consecutive ring tunnels. +data TunnelInfoChain gad t xs zp zq where + THNil :: TunnelInfoChain gad t '[ '(m,m') ] zp zq + THCons :: (xs ~ ('(r,r') ': '(s,s') ': rngs), e' ~ (e * (r' / r)), e ~ FGCD r s) + => TunnelInfo gad t e r s e' r' s' zp zq + -> TunnelInfoChain gad t (Tail xs) zp zq + -> TunnelInfoChain gad t xs zp zq + +instance NFData (TunnelInfoChain gad t '[ '(m,m') ] zp zq) where + rnf THNil = () + +instance (e' ~ (e * (r' / r)), e ~ FGCD r s, + NFData (TunnelInfo gad t e r s e' r' s' zp zq), + NFData (TunnelInfoChain gad t ('(s,s') ': rngs) zp zq)) + => NFData (TunnelInfoChain gad t ('(r,r') ': '(s,s') ': rngs) zp zq) where + rnf (THCons t ts) = rnf t `seq` rnf ts + +instance Protoable (TunnelInfoChain gad t '[ '(m,m') ] zp zq) where + type ProtoType (TunnelInfoChain gad t '[ '(m,m') ] zp zq) = P.TunnelInfoChain + toProto THNil = P.TunnelInfoChain empty + fromProto (P.TunnelInfoChain xs) | xs == empty = return THNil + fromProto _ = throwError $ "Got non-empty chain on fromProto for TunnelInfoChain" + +instance (e' ~ (e * (r' / r)), e ~ FGCD r s, + Protoable (TunnelInfo gad t e r s e' r' s' zp zq), + Protoable (TunnelInfoChain gad t ('(s,s') ': rngs) zp zq), + ProtoType (TunnelInfoChain gad t ('(s,s') ': rngs) zp zq) ~ P.TunnelInfoChain) + => Protoable (TunnelInfoChain gad t ('(r,r') ': '(s,s') ': rngs) zp zq) where + type ProtoType (TunnelInfoChain gad t ('(r,r') ': '(s,s') ': rngs) zp zq) = P.TunnelInfoChain + toProto (THCons hint rest) = + let h' = toProto hint + (P.TunnelInfoChain hs') = toProto rest + in P.TunnelInfoChain $ h' <| hs' + + fromProto (P.TunnelInfoChain zs) = do + when (zs == empty) $ throwError "fromProto TunnelInfo: expected at least one element" + let (x :< xs) = viewl zs + y <- fromProto x + ys <- fromProto $ P.TunnelInfoChain xs + return $ THCons y ys + +-- | Functions related to homomorphic ring tunneling. +class Tunnel xs t zp zq gad where + + -- | Generates 'TunnelInfo' for each tunnel step from @Head xs@ to @Last xs@. + tunnelInfoChain :: (MonadRandom rnd, Head xs ~ '(r,r'), Last xs ~ '(s,s'), + Lift zp z, CElt t z, ToInteger z, Reduce z zq) -- constraints involving 'z' from GenTunnelInfoCtx + => SK (Cyc t r' z) -> rnd (TunnelInfoChain gad t xs zp zq, SK (Cyc t s' z)) -- , TunnelFuncs t (PTRings xs) zp + + -- | Tunnel from @Head xs@ to @Last xs@. + tunnelInternal :: (Head xs ~ '(r,r'), Last xs ~ '(s,s')) => + TunnelInfoChain gad t xs zp zq -> CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq) + +instance Tunnel '[ '(m,m') ] t zp zq gad where + + tunnelInfoChain sk = return (THNil,sk) + + tunnelInternal _ = id + +-- EAC: I expand the GenTunnelInfoCtx synonym here to remove all occurrences of 'z', +-- which instead only occur in the context of tunnelInfoChain. This is because 'z' is +-- not relevant for tunnelInternal nor TunnelInfoChain, so we would have to pass +-- a proxy for 'z'. This is a problem I have had many times, and still don't have a +-- good solution for: the class exists only to match on the type list, all of +-- of the other class params exist only so I can write constrints involving the changing +-- params (here, the cyc indices) and the static params (here, the moduli/base rings). +-- One solution is to split the class in two: one with a 'z' param, and one without. +-- Another option is to pass in a meaningless proxy for 'z' to functions that don't need it. +-- Neither of these are good solutions, so instead I took a third approach: factor 'z' +-- out of the constraint synonyms. This requires explicitly listing the remaining +-- constraints, which is also ugly. +-- The root of this problem seems to be that the functions hold constant some +-- parameters, but change others, while the constraint synonyms refer to all of +-- them, even though some are orthogonal constraints. +instance (ExtendLinIdx e r s e' r' s', -- tunnelInfoChain + e' ~ (e * (r' / r)), -- tunnelInfoChain + e' `Divides` r', -- tunnelInfoChain + CElt t zp, Ring zq, Random zq, CElt t zq, -- tunnelInfoChain + Reduce (DecompOf zq) zq, Gadget gad zq, -- tunnelInfoChain + NFElt zq, CElt t (DecompOf zq), -- tunnelInfoChain + TunnelCtx t r s e' r' s' zp zq gad, -- tunnelCT + e ~ FGCD r s, e `Divides` r, e `Divides` s, -- linearDec + ZPP zp, TElt t (ZpOf zp), -- crtSet + Tunnel ('(s,s') ': rngs) t zp zq gad, -- recursive call + Protoable (TunnelInfo gad t e r s e' r' s' zp zq), + ProtoType (TunnelInfo gad t e r s e' r' s' zp zq) ~ P.TunnelInfo) -- toProto + => Tunnel ('(r,r') ': '(s,s') ': rngs) t zp zq gad where + + tunnelInfoChain sk = do + skout <- genSKWithVar sk + let crts = proxy crtSet (Proxy::Proxy e) + r = proxy totientFact (Proxy::Proxy r) + e = proxy totientFact (Proxy::Proxy e) + dim = r `div` e + -- only take as many crts as we need + -- otherwise linearDec fails + linf = linearDec (take dim crts) :: Linear t zp e r s + thint :: TunnelInfo gad t e r s e' r' s' zp zq <- tunnelInfo linf skout sk + (thints,sk') <- tunnelInfoChain skout + return (THCons thint thints, sk') + + tunnelInternal (THCons thint rest) = tunnelInternal rest . tunnelCT thint + +-- | Context for multi-step homomorphic tunneling. +type MultiTunnelCtx rngs r r' s s' t z zp zq gad zqs = + (Head rngs ~ '(r,r'), Last rngs ~ '(s,s'), Tunnel rngs t zp (ZqUp zq zqs) gad, ZqDown (ZqUp zq zqs) zqs ~ zq, + RescaleCyc (Cyc t) zq (ZqUp zq zqs), RescaleCyc (Cyc t) (ZqUp zq zqs) zq, RescaleCyc (Cyc t) zq (ZqDown zq zqs), + ToSDCtx t r' zp zq, ToSDCtx t s' zp (ZqUp zq zqs)) + +-- EAC: why round down twice? We bump the modulus up to begin with to handle +-- the key switches, so we knock thatt off, then another for accumulated noise +-- | End-to-end multi-step homomorphic tunneling. First add a modulus to the +-- ciphertext for the key switches, then 'tunnelInternal', then round down twice: +-- once to remove the key switch modulus, and once to dampen the noise incurred +-- while tunneling. +tunnel :: forall rngs r r' s s' t z zp zq gad zqs . (MultiTunnelCtx rngs r r' s s' t z zp zq gad zqs) + => Proxy zqs -> TunnelInfoChain gad t rngs zp (ZqUp zq zqs) -> CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' (ZqDown zq zqs)) +tunnel pzqs hints x = + let y = tunnelInternal hints $ roundCTUp pzqs x + in roundCTDown pzqs $ roundCTDown pzqs y + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- | Linear functions used for in-the-clear tunneling +data TunnelFuncs t xs zp where + TFNil :: TunnelFuncs t '[m] zp + TFCons :: (xs ~ (r ': s ': rngs)) + => Linear t zp (FGCD r s) r s + -> TunnelFuncs t (Tail xs) zp + -> TunnelFuncs t xs zp + +instance NFData (TunnelFuncs t '[m] zp) where + rnf TFNil = () + +instance (NFData (Linear t zp (FGCD r s) r s), NFData (TunnelFuncs t (s ': xs) zp)) + => NFData (TunnelFuncs t (r ': s ': xs) zp) where + rnf (TFCons f fs) = rnf f `seq` rnf fs + +instance Protoable (TunnelFuncs t '[m] zp) where + type ProtoType (TunnelFuncs t '[m] zp) = P.LinearFuncChain + toProto TFNil = P.LinearFuncChain empty + fromProto (P.LinearFuncChain s) | s == empty = return TFNil + fromProto _ = throwError $ "Got non-empty chain on fromProto for TunnelFuncs" + +instance (ProtoType (t s zp) ~ P.RqProduct, + Protoable (Linear t zp e r s), + Protoable (TunnelFuncs t (s ': rngs) zp), + ProtoType (TunnelFuncs t (s ': rngs) zp) ~ P.LinearFuncChain, + Tensor t, e ~ FGCD r s, Fact e, Fact r, Fact s) + => Protoable (TunnelFuncs t (r ': s ': rngs) zp) where + type ProtoType (TunnelFuncs t (r ': s ': rngs) zp) = P.LinearFuncChain + toProto (TFCons f fs) = + let f' = toProto f + (P.LinearFuncChain fs') = toProto fs + in P.LinearFuncChain $ f' <| fs' + fromProto (P.LinearFuncChain fs) = do + when (fs == empty) $ throwError "fromProto TunnelFuncs: expected at least one element" + let (a :< as) = viewl fs + b <- fromProto a + bs <- fromProto $ P.LinearFuncChain as + return $ TFCons b bs + +-- | The plaintext rings for a list of plaintext/ciphertext ring pairs. +type family PTRings xs where + PTRings '[] = '[] + PTRings ( '(a,b) ': rest ) = a ': (PTRings rest) + +-- | Functions for in-the-clear tunneling, needed to test the correctness of +-- homomorphic PRF evaluation. +class PTTunnel t xs zp where + -- | Generate the linear functions to apply when tunneling from @Head xs@ to @Last xs@. + ptTunnelFuncs :: TunnelFuncs t xs zp + -- | Tunnel a ring element from @Head xs@ to @Last xs@. + ptTunnel :: (Head xs ~ r, Last xs ~ s) => TunnelFuncs t xs zp -> Cyc t r zp -> Cyc t s zp + +instance PTTunnel t '[r] z where + ptTunnelFuncs = TFNil + ptTunnel TFNil = id + +instance (e ~ FGCD r s, e `Divides` r, e `Divides` s, PTTunnel t (s ': rngs) zp, + CElt t zp, -- evalLin + ZPP zp, TElt t (ZpOf zp) -- crtSet + ) + => PTTunnel t (r ': s ': rngs) zp where + ptTunnelFuncs = + let crts = proxy crtSet (Proxy::Proxy e) + r = proxy totientFact (Proxy::Proxy r) + e = proxy totientFact (Proxy::Proxy e) + dim = r `div` e + -- only take as many crts as we need + -- otherwise linearDec fails + linf = linearDec (take dim crts) :: Linear t zp e r s + linfs = ptTunnelFuncs + in TFCons linf linfs + ptTunnel (TFCons linf fs) = ptTunnel fs . evalLin linf diff --git a/Crypto/Lol/Applications/KeyHomomorphicPRF.hs b/Crypto/Lol/Applications/KeyHomomorphicPRF.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Applications/KeyHomomorphicPRF.hs @@ -0,0 +1,243 @@ +{-| +Module : Crypto.Lol.Applications.KeyHomomorphicPRF +Description : Key-homomorphic PRF from . +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Key-homomorphic PRF from . +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Crypto.Lol.Applications.KeyHomomorphicPRF +(FullBinTree(..), evalTree +,randomTree, balancedTree, leftSpineTree, rightSpineTree +,PRFFamily, makeFamily, randomFamily +,grayCode +,PRFState, prfState +,latticePRF, latticePRFM +,ringPRF, ringPRFM +) where + +import Control.Applicative ((<$>)) +import Control.DeepSeq +import Control.Monad.Random hiding (fromList) +import Control.Monad.State + +import Crypto.Lol + +import Data.Bits +import Data.Maybe (fromMaybe) + +import MathObj.Matrix + +-- | Full binary tree. +data FullBinTree = L + | I Int FullBinTree FullBinTree + +instance NFData FullBinTree where + rnf L = () + rnf (I i t1 t2) = rnf i `seq` rnf t1 `seq` rnf t2 + +-- | Parameters for PRF +data PRFFamily gad rq rp = + Params + (Matrix rq) -- a0 + (Matrix rq) -- a1 + FullBinTree -- tree + +instance (NFData rq) => NFData (PRFFamily gad rq rp) where + rnf (Params m1 m2 t) = rnf m1 `seq` rnf m2 `seq` rnf t + +-- | Smart constructor +makeFamily :: forall rq rp gad . (Gadget gad rq) + => Matrix rq -> Matrix rq -> FullBinTree -> PRFFamily gad rq rp +makeFamily a0 a1 + | numRows a0 /= numRows a1 = error $ "a0 has " ++ show (numRows a0) ++ + " rows, but a1 has " ++ show (numRows a1) ++ " rows." + | numColumns a0 /= (numRows a0)*(length $ untag (gadget :: Tagged gad [rq])) = + error $ "Expected " ++ show ((numRows a0)*(length $ untag (gadget :: Tagged gad [rq]))) ++ + " columns in a0, but there are " ++ show (numColumns a0) ++ "." + | numColumns a1 /= (numRows a1)*(length $ untag (gadget :: Tagged gad [rq])) = + error $ "Expected " ++ show ((numRows a1)*(length $ untag (gadget :: Tagged gad [rq]))) ++ + " columns in a1, but there are " ++ show (numColumns a1) ++ "." + | otherwise = Params a0 a1 + +-- not exported, +data DecoratedTree r = + -- input bit, output + DL Int (Matrix r) + -- numleaves, input value, output, left subtree, decomposed result of right subtree, right subtree + | DI Int Int (Matrix r) (DecoratedTree r) (Matrix r) (DecoratedTree r) + +instance (NFData r) => NFData (DecoratedTree r) where + rnf (DL i m) = rnf i `seq` rnf m + rnf (DI i1 i2 m1 d1 m2 d2) = rnf i1 `seq` rnf i2 `seq` rnf m1 `seq` rnf d1 `seq` rnf m2 `seq` rnf d2 + +-- | State of the PRF computation. This permits incremental computation. +data PRFState rq rp where + PRFState :: (Decompose gad rq) + => Proxy gad -> Matrix rq -> Matrix rq -> DecoratedTree rq -> PRFState rq rp + +instance (NFData rq) => NFData (PRFState rq rp) where + rnf (PRFState Proxy m1 m2 d) = rnf m1 `seq` rnf m2 `seq` rnf d + +-- | Given PRF parameters and an optional inital input value (default is 0), +-- produces an initial PRF state. +prfState :: forall gad rq rp . (Decompose gad rq) + => PRFFamily gad rq rp -> Maybe Int -> PRFState rq rp +prfState p@(Params a0 a1 t) initInput = + let treelen = case t of + L -> 1 + (I s _ _) -> s + input = fromMaybe 0 initInput -- default input is 0 + inputGuard = input >= 0 && input < 2^treelen + pgad = Proxy::Proxy gad + in if inputGuard + then PRFState pgad a0 a1 $ buildDecTree pgad input p + else + error $ "prfState: Input tree has " ++ show treelen ++ + " leaves, but input " ++ show input ++ " has " ++ + show (logBase 2 (fromIntegral input) :: Double) ++ " bits." + +-- given validated parameters, constructs a decorated tree with the given input +buildDecTree :: (Decompose gad rq) + => Proxy gad -> Int -> PRFFamily gad rq rp -> DecoratedTree rq +buildDecTree pgad y (Params a0 a1 t) = + let getNumLeaves L = 1 + getNumLeaves (I x _ _) = x + go 0 L = (a0, DL 0 a0) + go 1 L = (a1, DL 1 a1) + go x (I numLeaves ltree rtree) = + let numRightLeaves = getNumLeaves rtree + rbits = x .&. ((2^numRightLeaves)-1) -- mask high bits + lbits = shift x (-numRightLeaves) -- negate to shift right + (lval, ltree') = go lbits ltree + (rval, rtree') = go rbits rtree + decompr = fmap reduce $ proxy (decomposeMatrix rval) pgad + val = lval * decompr + in (val, DI numLeaves x val ltree' decompr rtree') + in snd $ go y t + +-- | Evaluates the tree at the new input, reusing as much prior work as possible. +evalTree :: Int -> PRFState rq rp -> (Matrix rq, PRFState rq rp) +evalTree y (PRFState pgad a0 a1 t) = + let getNumLeaves (DL _ _) = 1 + getNumLeaves (DI i _ _ _ _ _) = i + -- outputs result, new state, and flag indicating whether the state changed + go 0 (DL _ _) = (a0, DL 0 a0, False) + go 1 (DL _ _) = (a1, DL 1 a1, False) + go i n@(DI numLeaves x val ltree decompr rtree) + | i == x = (val,n, False) + | otherwise = + let numRightLeaves = getNumLeaves rtree + rbits = x .&. ((2^numRightLeaves)-1) -- mask high bits + lbits = shift x (-numRightLeaves) -- negate to shift right + (lval, ltree', _) = go lbits ltree + (rval, rtree', changed) = go rbits rtree + decompr' = if changed + then fmap reduce $ proxy (decomposeMatrix rval) pgad + else decompr + val' = lval * decompr' + in (val', DI numLeaves i val' ltree' decompr' rtree', True) + (res, t', _) = go y t + in (res, PRFState pgad a0 a1 t') + +-- | Equation (2.3) in . +latticePRF' :: (Rescale zq zp) + => Matrix zq -> Int -> PRFState zq zp -> (Matrix zp, PRFState zq zp) +latticePRF' s x state1@(PRFState _ a0 _ _) + | numRows s /= 1 = error "Secret key must have one row." + | numColumns s /= numRows a0 = error $ "Secret key has " ++ + show (numColumns s) ++ " columns, but a0 has " ++ + show (numRows a0) ++ " rows." + | otherwise = let (res,state2) = evalTree x state1 + in (rescale <$> s*res, state2) + +-- | Single-ouptut lattice PRF. +latticePRF :: (Rescale zq zp) + => Matrix zq -> Int -> PRFState zq zp -> Matrix zp +latticePRF s x = fst. latticePRF' s x + +-- | Multi-output lattice PRF with monadic memoized internal state. +latticePRFM :: (MonadState (PRFState zq zp) mon, Rescale zq zp) + => Matrix zq -> Int -> mon (Matrix zp) +latticePRFM s x = state $ latticePRF' s x + +-- | Equation (2.10) in . +ringPRF' :: (Fact m, RescaleCyc (Cyc t) zq zp, Ring rq, + rq ~ Cyc t m zq, rp ~ Cyc t m zp) + => rq -> Int -> PRFState rq rp -> (Matrix rp, PRFState rq rp) +ringPRF' s x state1 = + let (res,state2) = evalTree x state1 + in ((rescaleDec . (s*)) <$> res, state2) + +-- | Single-output ring PRF. +ringPRF :: (Fact m, RescaleCyc (Cyc t) zq zp, Ring rq, + rq ~ Cyc t m zq, rp ~ Cyc t m zp) + => rq -> Int -> PRFState rq rp -> Matrix rp +ringPRF s x = fst . ringPRF' s x + +-- | Multi-output ring PRF with monadic memoized internal state. +ringPRFM :: (MonadState (PRFState rq rp) mon, Fact m, + RescaleCyc (Cyc t) zq zp, Ring rq, + rq ~ Cyc t m zq, rp ~ Cyc t m zp) + => rq -> Int -> mon (Matrix rp) +ringPRFM s x = state $ ringPRF' s x + +-- convenience functions + +-- | Given the desired number of leaves, produces a random full binary tree. +randomTree :: (MonadRandom rnd) => Int -> rnd FullBinTree +randomTree 1 = return L +randomTree i = do + leftSize <- getRandomR (1,i-1) + left <- randomTree leftSize + right <- randomTree $ i-leftSize + return $ I i left right + +-- | Given the desired number of leaves, produces a full binary right-spine tree. +leftSpineTree :: Int -> FullBinTree +leftSpineTree 1 = L +leftSpineTree i = I i (leftSpineTree $ i-1) L + +-- | Given the desired number of leaves, produces a full binary left-spine tree. +rightSpineTree :: Int -> FullBinTree +rightSpineTree 1 = L +rightSpineTree i = I i L (rightSpineTree $ i-1) + +-- | Given the desired number of leaves, produces a full binary tree +-- which is complete, except possibly for the last level, which is left-biased. +balancedTree :: Int -> FullBinTree +balancedTree 1 = L +balancedTree i = + let lastFullLevelSize = 2^(floor (logBase 2 (fromIntegral i) :: Double) :: Int) + lsize = min lastFullLevelSize $ i-(lastFullLevelSize `div` 2) + rsize = i-lsize + in I i (balancedTree lsize) (balancedTree rsize) + +-- | Randomly generate ring-based PRF family. +randomFamily :: forall gad rnd rq rp . (MonadRandom rnd, Random rq, Gadget gad rq) + => Int -> rnd (PRFFamily gad rq rp) +randomFamily size = do -- in rnd + t <- randomTree size + let len = length $ untag (gadget :: Tagged gad [rq]) + a0 <- fromList 1 len <$> take len <$> getRandoms + a1 <- fromList 1 len <$> take len <$> getRandoms + return $ makeFamily a0 a1 t + +-- | Constructs an n-bit Gray code, useful for efficiently evaluating the PRF. +grayCode :: Int -> [Int] +grayCode 1 = [0,1] +grayCode n = + let gc' = grayCode (n-1) + pow2 = 2^(n-1) + rightHalf = map (+pow2) $ reverse gc' + in gc' ++ rightHalf diff --git a/Crypto/Lol/Applications/SymmSHE.hs b/Crypto/Lol/Applications/SymmSHE.hs --- a/Crypto/Lol/Applications/SymmSHE.hs +++ b/Crypto/Lol/Applications/SymmSHE.hs @@ -1,34 +1,58 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, GADTs, MultiParamTypeClasses, - NoImplicitPrelude, ScopedTypeVariables, TypeFamilies, - TypeOperators, UndecidableInstances #-} +{-| +Module : Crypto.Lol.Applications.SymmSHE +Description : Symmetric-key homomorphic encryption. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Symmetric-key somewhat homomorphic encryption. See Section 4 of --- http://eprint.iacr.org/2015/1134 for mathematical description. + \( \def\O{\mathcal{O}} \) +Symmetric-key somewhat homomorphic encryption. See Section 4 of + for mathematical description. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module Crypto.Lol.Applications.SymmSHE ( -- * Data types SK, PT, CT -- don't export constructors! -- * Keygen, encryption, decryption -, genSK +, genSK, genSKWithVar , encrypt , errorTerm, errorTermUnrestricted, decrypt, decryptUnrestricted -- * Arithmetic with public values -, addScalar, addPublic, mulPublic +, addScalar, addPublic, mulScalar, mulPublic -- * Modulus switching , rescaleLinearCT, modSwitchPT -- * Key switching +, KSLinearHint, KSQuadCircHint +, ksLinearHint, ksQuadCircHint , keySwitchLinear, keySwitchQuadCirc -- * Ring switching , embedSK, embedCT, twaceCT +, TunnelInfo, tunnelInfo , tunnelCT -- * Constraint synonyms , GenSKCtx, EncryptCtx, ToSDCtx, ErrorTermCtx , DecryptCtx, DecryptUCtx -, AddScalarCtx, AddPublicCtx, MulPublicCtx, ModSwitchPTCtx +, AddScalarCtx, AddPublicCtx, MulScalarCtx, MulPublicCtx, ModSwitchPTCtx , KeySwitchCtx, KSHintCtx -, TunnelCtx +, GenTunnelInfoCtx, TunnelCtx , SwitchCtx, LWECtx -- these are internal, but exported for better docs ) where @@ -37,13 +61,22 @@ import Crypto.Lol as LP hiding (sin) import Crypto.Lol.Cyclotomic.UCyc (D, UCyc) +import Crypto.Lol.Reflects +import Crypto.Lol.Types.Proto +import Crypto.Proto.Lol.R (R) +import Crypto.Proto.Lol.RqProduct (RqProduct) +import qualified Crypto.Proto.SHE.KSHint as P +import qualified Crypto.Proto.SHE.RqPolynomial as P +import qualified Crypto.Proto.SHE.SecretKey as P +import qualified Crypto.Proto.SHE.TunnelInfo as P import Control.Applicative hiding ((*>)) import Control.DeepSeq import Control.Monad as CM -import Control.Monad.Random +import Control.Monad.Random hiding (lift) import Data.Maybe import Data.Traversable as DT +import Data.Typeable import MathObj.Polynomial as P @@ -85,9 +118,15 @@ -- | Generates a secret key with (index-independent) scaled variance -- parameter \( v \); see 'errorRounded'. genSK :: (GenSKCtx t m z v, MonadRandom rnd) - => v -> rnd (SK (Cyc t m z)) + => v -> rnd (SK (Cyc t m z)) genSK v = liftM (SK v) $ errorRounded v +-- | Generates a secret key with the same scaled variance +-- as the input secret key. +genSKWithVar :: (ToInteger z, Fact m, CElt t z, MonadRandom rnd) + => SK a -> rnd (SK (Cyc t m z)) +genSKWithVar (SK v _) = genSK v + -- | Constraint synonym for encryption. type EncryptCtx t m m' z zp zq = (Mod zp, Ring zp, Ring zq, Lift zp (ModRep zp), Random zq, @@ -220,7 +259,7 @@ ---------- Key switching ---------- --- | Constraint synonym for generating an LWE sample. +-- | Constraint synonym for generating a ring-LWE sample. type LWECtx t m' z zq = (ToInteger z, Reduce z zq, Ring zq, Random zq, Fact m', CElt t z, CElt t zq) @@ -279,35 +318,46 @@ (RescaleCyc (Cyc t) zq' zq, RescaleCyc (Cyc t) zq zq', ToSDCtx t m' zp zq, SwitchCtx gad t m' zq') --- | Switch a linear ciphertext under \( s_{\text{in}} \) to a linear +-- | Hint for a linear key switch +newtype KSLinearHint gad r'q' = KSLHint (Tagged gad [Polynomial r'q']) deriving (NFData) + +-- | Hint for a circular quadratic key switch. +newtype KSQuadCircHint gad r'q' = KSQHint (Tagged gad [Polynomial r'q']) deriving (NFData) + +-- | A hint to switch a linear ciphertext under \( s_{\text{in}} \) to a linear -- one under \( s_{\text{out}} \). -keySwitchLinear :: forall gad t m' zp zq zq' z rnd m . - (KeySwitchCtx gad t m' zp zq zq', KSHintCtx gad t m' z zq', MonadRandom rnd) - => SK (Cyc t m' z) -- sout - -> SK (Cyc t m' z) -- sin - -> TaggedT (gad, zq') rnd (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) -keySwitchLinear skout (SK _ sin) = tagT $ do - hint :: Tagged gad [Polynomial (Cyc t m' zq')] <- ksHint skout sin - return $! hint `seq` - (\ct -> let CT MSD k l c = toMSD ct - [c0,c1] = coeffs c - c1' = rescalePow c1 - in CT MSD k l $ P.const c0 + rescaleLinearMSD (switch hint c1')) +ksLinearHint :: (KSHintCtx gad t m' z zq', MonadRandom rnd) + => SK (Cyc t m' z) -- sout + -> SK (Cyc t m' z) -- sin + -> rnd (KSLinearHint gad (Cyc t m' zq')) +ksLinearHint skout (SK _ sin) = KSLHint <$> ksHint skout sin --- | Switch a quadratic ciphertext (i.e., one with three components) --- to a linear one under the /same/ key. -keySwitchQuadCirc :: forall gad t m' zp zq zq' z m rnd . - (KeySwitchCtx gad t m' zp zq zq', KSHintCtx gad t m' z zq', MonadRandom rnd) +-- | Switch a linear ciphertext using the supplied hint. +keySwitchLinear :: (KeySwitchCtx gad t m' zp zq zq') + => KSLinearHint gad (Cyc t m' zq') -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +keySwitchLinear (KSLHint hint) ct = + let CT MSD k l c = toMSD ct + [c0,c1] = coeffs c + c1' = rescalePow c1 + in CT MSD k l $ P.const c0 + rescaleLinearMSD (switch hint c1') + +-- | A hint to switch a quadratic ciphertext to a linear +-- one under the same key. +ksQuadCircHint :: (KSHintCtx gad t m' z zq', MonadRandom rnd) => SK (Cyc t m' z) - -> TaggedT (gad, zq') rnd (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) -keySwitchQuadCirc sk@(SK _ s) = tagT $ do - hint :: Tagged gad [Polynomial (Cyc t m' zq')] <- ksHint sk (s*s) - return $ hint `seq` (\ct -> - let CT MSD k l c = toMSD ct - [c0,c1,c2] = coeffs c - c2' = rescalePow c2 - in CT MSD k l $ P.fromCoeffs [c0,c1] + rescaleLinearMSD (switch hint c2')) + -> rnd (KSQuadCircHint gad (Cyc t m' zq')) +ksQuadCircHint sk@(SK _ s) = KSQHint <$> ksHint sk (s*s) +-- | Switch a quadratic ciphertext (i.e., one with three components) +-- to a linear one under the /same/ key using the supplied hint. +keySwitchQuadCirc :: (KeySwitchCtx gad t m' zp zq zq') + => KSQuadCircHint gad (Cyc t m' zq') -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +keySwitchQuadCirc (KSQHint hint) ct = + let CT MSD k l c = toMSD ct + [c0,c1,c2] = coeffs c + c2' = rescalePow c2 + in CT MSD k l $ P.fromCoeffs [c0,c1] + rescaleLinearMSD (switch hint c2') + ---------- Misc homomorphic operations ---------- -- | Constraint synonym for adding a public scalar to a ciphertext. type AddScalarCtx t m' zp zq = @@ -323,9 +373,7 @@ in CT LSD k l $ c + (P.const $ reduce $ liftPow b') -- | Constraint synonym for adding a public value to an encrypted value. -type AddPublicCtx t m m' zp zq = - (Lift' zp, Reduce (LiftOf zp) zq, m `Divides` m', - CElt t zp, CElt t (LiftOf zp), ToSDCtx t m' zp zq) +type AddPublicCtx t m m' zp zq = (AddScalarCtx t m' zp zq, m `Divides` m') -- | Homomorphically add a public \( R_p \) value to an encrypted -- value. @@ -338,10 +386,22 @@ b' :: Cyc t m zq = reduce $ liftPow $ linv * (iterate mulG b !! k) in CT LSD k l $ c + P.const (embed b') +-- | Constraint synonym for multiplying a public scalar value with +-- an encrypted value. +type MulScalarCtx t m' zp zq = + (Lift' zp, Reduce (LiftOf zp) zq, Fact m', CElt t zq) + +-- | Homomorphically multiply a public \(\mathbb{Z}_p\) value to an +-- encrypted value. +mulScalar :: (MulScalarCtx t m' zp zq) + => zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +mulScalar a (CT enc k l c) = + let a' = scalarCyc $ reduce $ lift a + in CT enc k l $ (a' *) <$> c + -- | Constraint synonym for multiplying a public value with an encrypted value. type MulPublicCtx t m m' zp zq = - (Lift' zp, Reduce (LiftOf zp) zq, Ring zq, m `Divides` m', - CElt t zp, CElt t (LiftOf zp), CElt t zq) + (MulScalarCtx t m' zp zq, m `Divides` m', CElt t zp, CElt t (LiftOf zp)) -- | Homomorphically multiply an encrypted value by a public \( R_p \) -- value. @@ -359,21 +419,21 @@ ---------- NumericPrelude instances ---------- -instance (Eq zp, m `Divides` m', ToSDCtx t m' zp zq) +instance (Eq zp, MulScalarCtx t m' zp zq, m `Divides` m', ToSDCtx t m' zp zq) => Additive.C (CT m zp (Cyc t m' zq)) where zero = CT LSD 0 one zero -- the scales, g-exponents of ciphertexts, and MSD/LSD types must match. ct1@(CT enc1 k1 l1 c1) + ct2@(CT enc2 k2 l2 c2) - -- for simplicity, we don't currently support this. Shouldn't be - -- too complicated though. - | l1 /= l2 = error "Cannot add ciphertexts with different scale values" - | k1 < k2 = iterate mulGCT ct1 !! (k2-k1) + ct2 - | k1 > k2 = ct1 + iterate mulGCT ct2 !! (k1-k2) - | enc1 == LSD && enc2 == MSD = toMSD ct1 + ct2 - | enc1 == MSD && enc2 == LSD = ct1 + toMSD ct2 - | otherwise = CT enc1 k1 l1 $ c1 + c2 + | l1 /= l2 = + let (CT enc' k' _ c') = mulScalar (l1*(recip l2)) ct1 + in (CT enc' k' l2 c') + ct2 + | k1 < k2 = iterate mulGCT ct1 !! (k2-k1) + ct2 + | k1 > k2 = ct1 + iterate mulGCT ct2 !! (k1-k2) + | enc1 == LSD && enc2 == MSD = toMSD ct1 + ct2 + | enc1 == MSD && enc2 == LSD = ct1 + toMSD ct2 + | otherwise = CT enc1 k1 l1 $ c1 + c2 negate (CT enc k l c) = CT enc k l $ negate <$> c @@ -395,6 +455,7 @@ ---------- Ring switching ---------- +-- | Constraint synonym for 'absorbGFactors'. type AbsorbGCtx t m' zp zq = (Lift' zp, IntegralDomain zp, Reduce (LiftOf zp) zq, Ring zq, Fact m', CElt t (LiftOf zp), CElt t zp, CElt t zq) @@ -443,51 +504,128 @@ twaceCT (CT d 0 l c) = CT d 0 l (twace <$> c) twaceCT _ = error "twaceCT requires 0 factors of g; call absorbGFactors first" +-- | Auxilliary data needed to tunnel from \(\O_{r'}\) to \(\O_{s'}\). +data TunnelInfo gad t (e :: Factored) (r :: Factored) (s :: Factored) e' r' s' zp zq = + TInfo (Linear t zq e' r' s') [Tagged gad [Polynomial (Cyc t s' zq)]] +instance (NFData (Linear t zq e' r' s'), NFData (Cyc t s' zq)) + => NFData (TunnelInfo gad t e r s e' r' s' zp zq) where + rnf (TInfo l t) = rnf l `seq` rnf t + +-- EAC: `e' ~ (e * ...) is not needed in this module, but it is needed as use sites... +-- | Constraint synonym for generating 'TunnelInfo'. +type GenTunnelInfoCtx t e r s e' r' s' z zp zq gad = + (ExtendLinIdx e r s e' r' s', -- extendLin + e' ~ (e * (r' / r)), -- convenience; implied by prev constraint + KSHintCtx gad t r' z zq, -- ksHint + Lift zp z, CElt t zp, -- liftLin + CElt t z, e' `Divides` r') -- powBasis + +-- | Generates auxilliary data needed to tunnel from \(\O_{r'}\) to \(\O_{s'}\). +tunnelInfo :: forall gad t e r s e' r' s' z zp zq rnd . + (MonadRandom rnd, GenTunnelInfoCtx t e r s e' r' s' z zp zq gad) + => Linear t zp e r s + -> SK (Cyc t s' z) + -> SK (Cyc t r' z) + -> rnd (TunnelInfo gad t e r s e' r' s' zp zq) +tunnelInfo f skout (SK _ sin) = -- generate hints + (let f' = extendLin $ lift f :: Linear t z e' r' s' + f'q = reduce f' :: Linear t zq e' r' s' + -- choice of basis here must match coeffs* basis below + ps = proxy powBasis (Proxy::Proxy e') + comps = (evalLin f' . (adviseCRT sin *)) <$> ps + in TInfo f'q <$> CM.mapM (ksHint skout) comps) + \\ lcmDivides (Proxy::Proxy r) (Proxy::Proxy e') + -- | Constraint synonym for ring tunneling. -type TunnelCtx t e r s e' r' s' z zp zq gad = - (ExtendLinIdx e r s e' r' s', -- liftLin - e' ~ (e * (r' / r)), -- convenience; implied by prev constraint - ToSDCtx t r' zp zq, -- toMSD - KSHintCtx gad t r' z zq, -- ksHint - Reduce z zq, -- Reduce on Linear - Lift zp z, -- liftLin - IntegralDomain zp, -- absorbGFactors - CElt t zp, -- liftLin - SwitchCtx gad t s' zq) -- switch +type TunnelCtx t r s e' r' s' zp zq gad = + (Fact r, Fact s, e' `Divides` r', e' `Divides` s', CElt t zp, -- evalLin + ToSDCtx t r' zp zq, -- toMSD + AbsorbGCtx t r' zp zq, -- absorbGFactors + SwitchCtx gad t s' zq) -- switch -- | Homomorphically apply the \( E \)-linear function that maps the -- elements of the decoding basis of \( R/E \) to the corresponding -- \( S \)-elements in the input array. -tunnelCT :: forall gad t e r s e' r' s' z zp zq rnd . - (TunnelCtx t e r s e' r' s' z zp zq gad, - MonadRandom rnd) - => Linear t zp e r s - -> SK (Cyc t s' z) - -> SK (Cyc t r' z) - -> TaggedT gad rnd (CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq)) -tunnelCT f skout (SK _ sin) = tagT $ (do -- in rnd - -- generate hints - let f' = extendLin $ lift f :: Linear t z e' r' s' - f'q = reduce f' :: Linear t zq e' r' s' - -- choice of basis here must match coeffs* basis below - ps = proxy powBasis (Proxy::Proxy e') - comps = (evalLin f' . (adviseCRT sin *)) <$> ps - hints :: [Tagged gad [Polynomial (Cyc t s' zq)]] <- CM.mapM (ksHint skout) comps - return $ hints `deepseq` \ct -> - let CT MSD 0 s c = toMSD $ absorbGFactors ct - [c0,c1] = coeffs c - -- apply E-linear function to constant term c0 - c0' = evalLin f'q c0 - -- apply E-linear function to c1 via key-switching - -- this basis must match the basis used above to generate the hints - c1s = coeffsPow c1 :: [Cyc t e' zq] - -- CJP: don't embed the c1s before decomposing them (inside - -- switch); instead decompose in smaller ring before - -- embedding (it matters). - -- We may need to generalize switch or define an - -- alternative. - c1s' = zipWith switch hints (embed <$> c1s) - c1' = sum c1s' - in CT MSD 0 s $ P.const c0' + c1') - \\ lcmDivides (Proxy::Proxy r) (Proxy::Proxy e') +tunnelCT :: forall gad t e r s e' r' s' zp zq . + (TunnelCtx t r s e' r' s' zp zq gad, e ~ FGCD r s) + => TunnelInfo gad t e r s e' r' s' zp zq + -> CT r zp (Cyc t r' zq) + -> CT s zp (Cyc t s' zq) +tunnelCT (TInfo f'q hints) ct = + (let CT MSD 0 s c = toMSD $ absorbGFactors ct + [c0,c1] = coeffs c + -- apply E-linear function to constant term c0 + c0' = evalLin f'q c0 + -- apply E-linear function to c1 via key-switching + -- this basis must match the basis used above to generate the hints + c1s = coeffsPow c1 :: [Cyc t e' zq] + -- CJP: don't embed the c1s before decomposing them (inside + -- switch); instead decompose in smaller ring before + -- embedding (it matters). + -- We may need to generalize switch or define an + -- alternative. + c1s' = zipWith switch hints (embed <$> c1s) + c1' = sum c1s' + in CT MSD 0 s $ P.const c0' + c1') + \\ lcmDivides (Proxy::Proxy r) (Proxy::Proxy e') + +instance (Protoable r, ProtoType r ~ R) => Protoable (SK r) where + type ProtoType (SK r) = P.SecretKey + toProto (SK v r) = P.SecretKey (toProto r) (realToField v) + fromProto (P.SecretKey r v) = (SK v) <$> fromProto r + +instance (Protoable rq, ProtoType rq ~ RqProduct) => Protoable (Polynomial rq) where + type ProtoType (Polynomial rq) = P.RqPolynomial + toProto = P.RqPolynomial . toProto . coeffs + fromProto (P.RqPolynomial x) = fromCoeffs <$> fromProto x + +instance (Typeable gad, Protoable r'q', ProtoType r'q' ~ RqProduct) + => Protoable (KSLinearHint gad r'q') where + type ProtoType (KSLinearHint gad r'q') = P.KSHint + toProto (KSLHint cs) = + P.KSHint + (toProto $ proxy cs (Proxy::Proxy gad)) + (toProto $ typeRepFingerprint $ typeRep (Proxy::Proxy gad)) + fromProto (P.KSHint poly gadrepr') = do + let gadrepr = toProto $ typeRepFingerprint $ typeRep (Proxy::Proxy gad) + if gadrepr == gadrepr' + then (KSLHint . tag) <$> fromProto poly + else error $ "Expected gadget " ++ (show $ typeRep (Proxy::Proxy gad)) + +instance (Typeable gad, Protoable r'q', ProtoType r'q' ~ RqProduct) + => Protoable (KSQuadCircHint gad r'q') where + type ProtoType (KSQuadCircHint gad r'q') = P.KSHint + toProto (KSQHint x) = toProto $ KSLHint x + fromProto y = do + (KSLHint x) <- fromProto y + return $ KSQHint x + +instance (Mod zp, Typeable gad, + Protoable (Linear t zq e' r' s'), + Protoable (KSLinearHint gad (Cyc t s' zq)), Reflects s Int, Reflects r Int, Reflects e Int) + => Protoable (TunnelInfo gad t e r s e' r' s' zp zq) where + type ProtoType (TunnelInfo gad t e r s e' r' s' zp zq) = P.TunnelInfo + toProto (TInfo linf hints) = + P.TunnelInfo + (toProto linf) + (toProto $ KSLHint <$> hints) + (fromIntegral (proxy value (Proxy::Proxy e) :: Int)) + (fromIntegral (proxy value (Proxy::Proxy r) :: Int)) + (fromIntegral (proxy value (Proxy::Proxy s) :: Int)) + (fromIntegral $ proxy modulus (Proxy::Proxy zp)) + fromProto (P.TunnelInfo linf hints e r s p) = + let e' = fromIntegral $ (proxy value (Proxy::Proxy e) :: Int) + r' = fromIntegral $ (proxy value (Proxy::Proxy r) :: Int) + s' = fromIntegral $ (proxy value (Proxy::Proxy s) :: Int) + p' = fromIntegral $ proxy modulus (Proxy::Proxy zp) + in if p' == p && e' == e && r' == r && s' == s + then do + linf' <- fromProto linf + hs <- (map (\(KSLHint x) -> x)) <$> fromProto hints + return $ TInfo linf' hs + else error $ "Error reading TunnelInfo proto data:" ++ + "\nexpected p=" ++ show p' ++ ", got " ++ show p ++ + "\nexpected e=" ++ show e' ++ ", got " ++ show e ++ + "\nexpected r=" ++ show r' ++ ", got " ++ show r ++ + "\nexpected s=" ++ show s' ++ ", got " ++ show s diff --git a/Crypto/Proto/HomomPRF.hs b/Crypto/Proto/HomomPRF.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/HomomPRF.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.HomomPRF (protoInfo, fileDescriptorProto) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import Text.DescriptorProtos.FileDescriptorProto (FileDescriptorProto) +import Text.ProtocolBuffers.Reflections (ProtoInfo) +import qualified Text.ProtocolBuffers.WireMessage as P' (wireGet,getFromBS) + +protoInfo :: ProtoInfo +protoInfo + = Prelude'.read + "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".HomomPRF\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [], baseName = MName \"HomomPRF\"}, protoFilePath = [\"Crypto\",\"Proto\",\"HomomPRF.hs\"], protoSource = \"HomomPRF.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".HomomPRF.LinearFuncChain\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"HomomPRF\"], baseName = MName \"LinearFuncChain\"}, descFilePath = [\"Crypto\",\"Proto\",\"HomomPRF\",\"LinearFuncChain.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".HomomPRF.LinearFuncChain.funcs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"HomomPRF\",MName \"LinearFuncChain\"], baseName' = FName \"funcs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.LinearRq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"LinearRq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".HomomPRF.TunnelInfoChain\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"HomomPRF\"], baseName = MName \"TunnelInfoChain\"}, descFilePath = [\"Crypto\",\"Proto\",\"HomomPRF\",\"TunnelInfoChain.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".HomomPRF.TunnelInfoChain.hints\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"HomomPRF\",MName \"TunnelInfoChain\"], baseName' = FName \"hints\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.TunnelInfo\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"TunnelInfo\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".HomomPRF.RoundHintChain\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"HomomPRF\"], baseName = MName \"RoundHintChain\"}, descFilePath = [\"Crypto\",\"Proto\",\"HomomPRF\",\"RoundHintChain.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".HomomPRF.RoundHintChain.hints\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"HomomPRF\",MName \"RoundHintChain\"], baseName' = FName \"hints\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.KSHint\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"KSHint\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [], oneofs = [], knownKeyMap = fromList []}" + +fileDescriptorProto :: FileDescriptorProto +fileDescriptorProto + = P'.getFromBS (P'.wireGet 11) + (P'.pack + "\184\SOH\n\SO\&HomomPRF.proto\SUB\tLol.proto\SUB\tSHE.proto\"/\n\SILinearFuncChain\DC2\FS\n\ENQfuncs\CAN\SOH \ETX(\v2\r.Lol.LinearRq\"1\n\SITunnelInfoChain\DC2\RS\n\ENQhints\CAN\SOH \ETX(\v2\SI.SHE.TunnelInfo\",\n\SORoundHintChain\DC2\SUB\n\ENQhints\CAN\SOH \ETX(\v2\v.SHE.KSHint") diff --git a/Crypto/Proto/HomomPRF/LinearFuncChain.hs b/Crypto/Proto/HomomPRF/LinearFuncChain.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/HomomPRF/LinearFuncChain.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.HomomPRF.LinearFuncChain (LinearFuncChain(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.LinearRq as Lol (LinearRq) + +data LinearFuncChain = LinearFuncChain{funcs :: !(P'.Seq Lol.LinearRq)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable LinearFuncChain where + mergeAppend (LinearFuncChain x'1) (LinearFuncChain y'1) = LinearFuncChain (P'.mergeAppend x'1 y'1) + +instance P'.Default LinearFuncChain where + defaultValue = LinearFuncChain P'.defaultValue + +instance P'.Wire LinearFuncChain where + wireSize ft' self'@(LinearFuncChain x'1) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1) + wirePut ft' self'@(LinearFuncChain x'1) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{funcs = P'.append (funcs old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> LinearFuncChain) LinearFuncChain where + getVal m' f' = f' m' + +instance P'.GPB LinearFuncChain + +instance P'.ReflectDescriptor LinearFuncChain where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".HomomPRF.LinearFuncChain\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"HomomPRF\"], baseName = MName \"LinearFuncChain\"}, descFilePath = [\"Crypto\",\"Proto\",\"HomomPRF\",\"LinearFuncChain.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".HomomPRF.LinearFuncChain.funcs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"HomomPRF\",MName \"LinearFuncChain\"], baseName' = FName \"funcs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.LinearRq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"LinearRq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType LinearFuncChain where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg LinearFuncChain where + textPut msg + = do + P'.tellT "funcs" (funcs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'funcs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'funcs + = P'.try + (do + v <- P'.getT "funcs" + Prelude'.return (\ o -> o{funcs = P'.append (funcs o) v})) diff --git a/Crypto/Proto/HomomPRF/RoundHintChain.hs b/Crypto/Proto/HomomPRF/RoundHintChain.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/HomomPRF/RoundHintChain.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.HomomPRF.RoundHintChain (RoundHintChain(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.SHE.KSHint as SHE (KSHint) + +data RoundHintChain = RoundHintChain{hints :: !(P'.Seq SHE.KSHint)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable RoundHintChain where + mergeAppend (RoundHintChain x'1) (RoundHintChain y'1) = RoundHintChain (P'.mergeAppend x'1 y'1) + +instance P'.Default RoundHintChain where + defaultValue = RoundHintChain P'.defaultValue + +instance P'.Wire RoundHintChain where + wireSize ft' self'@(RoundHintChain x'1) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1) + wirePut ft' self'@(RoundHintChain x'1) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{hints = P'.append (hints old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> RoundHintChain) RoundHintChain where + getVal m' f' = f' m' + +instance P'.GPB RoundHintChain + +instance P'.ReflectDescriptor RoundHintChain where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".HomomPRF.RoundHintChain\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"HomomPRF\"], baseName = MName \"RoundHintChain\"}, descFilePath = [\"Crypto\",\"Proto\",\"HomomPRF\",\"RoundHintChain.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".HomomPRF.RoundHintChain.hints\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"HomomPRF\",MName \"RoundHintChain\"], baseName' = FName \"hints\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.KSHint\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"KSHint\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType RoundHintChain where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg RoundHintChain where + textPut msg + = do + P'.tellT "hints" (hints msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'hints]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'hints + = P'.try + (do + v <- P'.getT "hints" + Prelude'.return (\ o -> o{hints = P'.append (hints o) v})) diff --git a/Crypto/Proto/HomomPRF/TunnelInfoChain.hs b/Crypto/Proto/HomomPRF/TunnelInfoChain.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/HomomPRF/TunnelInfoChain.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.HomomPRF.TunnelInfoChain (TunnelInfoChain(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.SHE.TunnelInfo as SHE (TunnelInfo) + +data TunnelInfoChain = TunnelInfoChain{hints :: !(P'.Seq SHE.TunnelInfo)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable TunnelInfoChain where + mergeAppend (TunnelInfoChain x'1) (TunnelInfoChain y'1) = TunnelInfoChain (P'.mergeAppend x'1 y'1) + +instance P'.Default TunnelInfoChain where + defaultValue = TunnelInfoChain P'.defaultValue + +instance P'.Wire TunnelInfoChain where + wireSize ft' self'@(TunnelInfoChain x'1) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1) + wirePut ft' self'@(TunnelInfoChain x'1) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{hints = P'.append (hints old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> TunnelInfoChain) TunnelInfoChain where + getVal m' f' = f' m' + +instance P'.GPB TunnelInfoChain + +instance P'.ReflectDescriptor TunnelInfoChain where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".HomomPRF.TunnelInfoChain\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"HomomPRF\"], baseName = MName \"TunnelInfoChain\"}, descFilePath = [\"Crypto\",\"Proto\",\"HomomPRF\",\"TunnelInfoChain.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".HomomPRF.TunnelInfoChain.hints\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"HomomPRF\",MName \"TunnelInfoChain\"], baseName' = FName \"hints\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.TunnelInfo\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"TunnelInfo\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType TunnelInfoChain where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg TunnelInfoChain where + textPut msg + = do + P'.tellT "hints" (hints msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'hints]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'hints + = P'.try + (do + v <- P'.getT "hints" + Prelude'.return (\ o -> o{hints = P'.append (hints o) v})) diff --git a/Crypto/Proto/SHE.hs b/Crypto/Proto/SHE.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/SHE.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.SHE (protoInfo, fileDescriptorProto) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import Text.DescriptorProtos.FileDescriptorProto (FileDescriptorProto) +import Text.ProtocolBuffers.Reflections (ProtoInfo) +import qualified Text.ProtocolBuffers.WireMessage as P' (wireGet,getFromBS) + +protoInfo :: ProtoInfo +protoInfo + = Prelude'.read + "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".SHE\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [], baseName = MName \"SHE\"}, protoFilePath = [\"Crypto\",\"Proto\",\"SHE.hs\"], protoSource = \"SHE.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.SecretKey\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"SecretKey\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"SecretKey.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.SecretKey.sk\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"SecretKey\"], baseName' = FName \"sk\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.R\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"R\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.SecretKey.v\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"SecretKey\"], baseName' = FName \"v\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 17}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.RqPolynomial\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"RqPolynomial\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"RqPolynomial.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.RqPolynomial.coeffs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"RqPolynomial\"], baseName' = FName \"coeffs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.KSHint\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"KSHint\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"KSHint.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.KSHint.hint\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"KSHint\"], baseName' = FName \"hint\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.RqPolynomial\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"RqPolynomial\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.KSHint.gad\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"KSHint\"], baseName' = FName \"gad\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.TypeRep\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"TypeRep\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.TunnelInfo\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"TunnelInfo\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"TunnelInfo.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.func\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"func\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.LinearRq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"LinearRq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.hint\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"hint\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.KSHint\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"KSHint\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.e\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"e\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.r\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"r\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 32}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.s\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"s\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.p\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"p\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 48}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [], oneofs = [], knownKeyMap = fromList []}" + +fileDescriptorProto :: FileDescriptorProto +fileDescriptorProto + = P'.getFromBS (P'.wireGet 11) + (P'.pack + "\170\STX\n\tSHE.proto\SUB\tLol.proto\"*\n\tSecretKey\DC2\DC2\n\STXsk\CAN\SOH \STX(\v2\ACK.Lol.R\DC2\t\n\SOHv\CAN\STX \STX(\SOH\".\n\fRqPolynomial\DC2\RS\n\ACKcoeffs\CAN\SOH \ETX(\v2\SO.Lol.RqProduct\"D\n\ACKKSHint\DC2\US\n\EOThint\CAN\SOH \ETX(\v2\DC1.SHE.RqPolynomial\DC2\EM\n\ETXgad\CAN\STX \STX(\v2\f.Lol.TypeRep\"p\n\nTunnelInfo\DC2\ESC\n\EOTfunc\CAN\SOH \STX(\v2\r.Lol.LinearRq\DC2\EM\n\EOThint\CAN\STX \ETX(\v2\v.SHE.KSHint\DC2\t\n\SOHe\CAN\ETX \STX(\r\DC2\t\n\SOHr\CAN\EOT \STX(\r\DC2\t\n\SOHs\CAN\ENQ \STX(\r\DC2\t\n\SOHp\CAN\ACK \STX(\EOT") diff --git a/Crypto/Proto/SHE/KSHint.hs b/Crypto/Proto/SHE/KSHint.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/SHE/KSHint.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.SHE.KSHint (KSHint(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.TypeRep as Lol (TypeRep) +import qualified Crypto.Proto.SHE.RqPolynomial as SHE (RqPolynomial) + +data KSHint = KSHint{hint :: !(P'.Seq SHE.RqPolynomial), gad :: !(Lol.TypeRep)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable KSHint where + mergeAppend (KSHint x'1 x'2) (KSHint y'1 y'2) = KSHint (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default KSHint where + defaultValue = KSHint P'.defaultValue P'.defaultValue + +instance P'.Wire KSHint where + wireSize ft' self'@(KSHint x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(KSHint x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{hint = P'.append (hint old'Self) new'Field}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{gad = P'.mergeAppend (gad old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> KSHint) KSHint where + getVal m' f' = f' m' + +instance P'.GPB KSHint + +instance P'.ReflectDescriptor KSHint where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.KSHint\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"KSHint\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"KSHint.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.KSHint.hint\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"KSHint\"], baseName' = FName \"hint\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.RqPolynomial\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"RqPolynomial\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.KSHint.gad\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"KSHint\"], baseName' = FName \"gad\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.TypeRep\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"TypeRep\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType KSHint where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg KSHint where + textPut msg + = do + P'.tellT "hint" (hint msg) + P'.tellT "gad" (gad msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'hint, parse'gad]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'hint + = P'.try + (do + v <- P'.getT "hint" + Prelude'.return (\ o -> o{hint = P'.append (hint o) v})) + parse'gad + = P'.try + (do + v <- P'.getT "gad" + Prelude'.return (\ o -> o{gad = v})) diff --git a/Crypto/Proto/SHE/RqPolynomial.hs b/Crypto/Proto/SHE/RqPolynomial.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/SHE/RqPolynomial.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.SHE.RqPolynomial (RqPolynomial(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.RqProduct as Lol (RqProduct) + +data RqPolynomial = RqPolynomial{coeffs :: !(P'.Seq Lol.RqProduct)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable RqPolynomial where + mergeAppend (RqPolynomial x'1) (RqPolynomial y'1) = RqPolynomial (P'.mergeAppend x'1 y'1) + +instance P'.Default RqPolynomial where + defaultValue = RqPolynomial P'.defaultValue + +instance P'.Wire RqPolynomial where + wireSize ft' self'@(RqPolynomial x'1) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1) + wirePut ft' self'@(RqPolynomial x'1) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{coeffs = P'.append (coeffs old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> RqPolynomial) RqPolynomial where + getVal m' f' = f' m' + +instance P'.GPB RqPolynomial + +instance P'.ReflectDescriptor RqPolynomial where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.RqPolynomial\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"RqPolynomial\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"RqPolynomial.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.RqPolynomial.coeffs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"RqPolynomial\"], baseName' = FName \"coeffs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType RqPolynomial where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg RqPolynomial where + textPut msg + = do + P'.tellT "coeffs" (coeffs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'coeffs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'coeffs + = P'.try + (do + v <- P'.getT "coeffs" + Prelude'.return (\ o -> o{coeffs = P'.append (coeffs o) v})) diff --git a/Crypto/Proto/SHE/SecretKey.hs b/Crypto/Proto/SHE/SecretKey.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/SHE/SecretKey.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.SHE.SecretKey (SecretKey(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.R as Lol (R) + +data SecretKey = SecretKey{sk :: !(Lol.R), v :: !(P'.Double)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SecretKey where + mergeAppend (SecretKey x'1 x'2) (SecretKey y'1 y'2) = SecretKey (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SecretKey where + defaultValue = SecretKey P'.defaultValue P'.defaultValue + +instance P'.Wire SecretKey where + wireSize ft' self'@(SecretKey x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 1 x'2) + wirePut ft' self'@(SecretKey x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 17 1 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{sk = P'.mergeAppend (sk old'Self) (new'Field)}) (P'.wireGet 11) + 17 -> Prelude'.fmap (\ !new'Field -> old'Self{v = new'Field}) (P'.wireGet 1) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SecretKey) SecretKey where + getVal m' f' = f' m' + +instance P'.GPB SecretKey + +instance P'.ReflectDescriptor SecretKey where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 17]) (P'.fromDistinctAscList [10, 17]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.SecretKey\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"SecretKey\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"SecretKey.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.SecretKey.sk\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"SecretKey\"], baseName' = FName \"sk\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.R\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"R\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.SecretKey.v\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"SecretKey\"], baseName' = FName \"v\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 17}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SecretKey where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SecretKey where + textPut msg + = do + P'.tellT "sk" (sk msg) + P'.tellT "v" (v msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'sk, parse'v]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'sk + = P'.try + (do + v <- P'.getT "sk" + Prelude'.return (\ o -> o{sk = v})) + parse'v + = P'.try + (do + v <- P'.getT "v" + Prelude'.return (\ o -> o{v = v})) diff --git a/Crypto/Proto/SHE/TunnelInfo.hs b/Crypto/Proto/SHE/TunnelInfo.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/SHE/TunnelInfo.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.SHE.TunnelInfo (TunnelInfo(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.LinearRq as Lol (LinearRq) +import qualified Crypto.Proto.SHE.KSHint as SHE (KSHint) + +data TunnelInfo = TunnelInfo{func :: !(Lol.LinearRq), hint :: !(P'.Seq SHE.KSHint), e :: !(P'.Word32), r :: !(P'.Word32), + s :: !(P'.Word32), p :: !(P'.Word64)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable TunnelInfo where + mergeAppend (TunnelInfo x'1 x'2 x'3 x'4 x'5 x'6) (TunnelInfo y'1 y'2 y'3 y'4 y'5 y'6) + = TunnelInfo (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + (P'.mergeAppend x'5 y'5) + (P'.mergeAppend x'6 y'6) + +instance P'.Default TunnelInfo where + defaultValue = TunnelInfo P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue + +instance P'.Wire TunnelInfo where + wireSize ft' self'@(TunnelInfo x'1 x'2 x'3 x'4 x'5 x'6) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size + = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeRep 1 11 x'2 + P'.wireSizeReq 1 13 x'3 + P'.wireSizeReq 1 13 x'4 + + P'.wireSizeReq 1 13 x'5 + + P'.wireSizeReq 1 4 x'6) + wirePut ft' self'@(TunnelInfo x'1 x'2 x'3 x'4 x'5 x'6) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutRep 18 11 x'2 + P'.wirePutReq 24 13 x'3 + P'.wirePutReq 32 13 x'4 + P'.wirePutReq 40 13 x'5 + P'.wirePutReq 48 4 x'6 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{func = P'.mergeAppend (func old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{hint = P'.append (hint old'Self) new'Field}) (P'.wireGet 11) + 24 -> Prelude'.fmap (\ !new'Field -> old'Self{e = new'Field}) (P'.wireGet 13) + 32 -> Prelude'.fmap (\ !new'Field -> old'Self{r = new'Field}) (P'.wireGet 13) + 40 -> Prelude'.fmap (\ !new'Field -> old'Self{s = new'Field}) (P'.wireGet 13) + 48 -> Prelude'.fmap (\ !new'Field -> old'Self{p = new'Field}) (P'.wireGet 4) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> TunnelInfo) TunnelInfo where + getVal m' f' = f' m' + +instance P'.GPB TunnelInfo + +instance P'.ReflectDescriptor TunnelInfo where + getMessageInfo _ + = P'.GetMessageInfo (P'.fromDistinctAscList [10, 24, 32, 40, 48]) (P'.fromDistinctAscList [10, 18, 24, 32, 40, 48]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".SHE.TunnelInfo\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"TunnelInfo\"}, descFilePath = [\"Crypto\",\"Proto\",\"SHE\",\"TunnelInfo.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.func\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"func\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.LinearRq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"LinearRq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.hint\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"hint\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".SHE.KSHint\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"SHE\"], baseName = MName \"KSHint\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.e\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"e\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.r\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"r\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 32}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.s\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"s\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".SHE.TunnelInfo.p\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"SHE\",MName \"TunnelInfo\"], baseName' = FName \"p\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 48}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType TunnelInfo where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg TunnelInfo where + textPut msg + = do + P'.tellT "func" (func msg) + P'.tellT "hint" (hint msg) + P'.tellT "e" (e msg) + P'.tellT "r" (r msg) + P'.tellT "s" (s msg) + P'.tellT "p" (p msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'func, parse'hint, parse'e, parse'r, parse's, parse'p]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'func + = P'.try + (do + v <- P'.getT "func" + Prelude'.return (\ o -> o{func = v})) + parse'hint + = P'.try + (do + v <- P'.getT "hint" + Prelude'.return (\ o -> o{hint = P'.append (hint o) v})) + parse'e + = P'.try + (do + v <- P'.getT "e" + Prelude'.return (\ o -> o{e = v})) + parse'r + = P'.try + (do + v <- P'.getT "r" + Prelude'.return (\ o -> o{r = v})) + parse's + = P'.try + (do + v <- P'.getT "s" + Prelude'.return (\ o -> o{s = v})) + parse'p + = P'.try + (do + v <- P'.getT "p" + Prelude'.return (\ o -> o{p = v})) diff --git a/HomomPRF.proto b/HomomPRF.proto new file mode 100644 --- /dev/null +++ b/HomomPRF.proto @@ -0,0 +1,26 @@ +// proto messages for precomputation step of homomorphic PRF +// evaluation and testing + +// These messages are just repeated messages from SHE.proto, used when multiple +// operations (on different types) are done in sequence. This avoids having +// to load messages for each step of a computation, which could be error prone +// since the messages are type-specific. + +import "Lol.proto"; +import "SHE.proto"; + +// run this: + +// hprotoc -I ../lol -a Lol.proto=Crypto.Proto -a SHE.proto=Crypto.Proto -p Crypto.Proto HomomPRF.proto + +message LinearFuncChain { + repeated LinearRq funcs = 1; +} + +message TunnelInfoChain { + repeated TunnelInfo hints = 1; +} + +message RoundHintChain { + repeated KSHint hints = 1; +} diff --git a/README b/README --- a/README +++ b/README @@ -3,3 +3,15 @@ * SymmSHE.hs gives an implementation of a symmetric-key, somewhat-homomorphic encryption scheme that is essentially equivalent to the one from the toolkit paper [LPR'13]. + +* KeyHomomorphicPRF.hs gives an implementation of the + key-homomorphic pseudo-random function from Banerjee + and Peikert in Crypto 2014 ([BP14]). + +* HomomPRF provides an interface for the homomorphic evaluation of the [BP14] + PRF. + +Note that an example using each application can be found in the 'examples' +directory. Tests and benchmarks for SHE and KeyHomomorphicPRF are provided in +the 'tests' and 'benchmarks' directories. Tests and benchmarks for HomomPRF are +included in the example for HomomPRF. diff --git a/SHE.proto b/SHE.proto new file mode 100644 --- /dev/null +++ b/SHE.proto @@ -0,0 +1,33 @@ +// proto messages for key switch hints and secret keys from SymmSHE + +import "Lol.proto"; + +// run this: + +// hprotoc -I ../lol -a Lol.proto=Crypto.Proto -p Crypto.Proto SHE.proto + +message SecretKey { + required R sk = 1; // ring element + required double v = 2; // scaled variance +} + +// internally used in KSHint +message RqPolynomial { + repeated RqProduct coeffs = 1; // constant coefficient first, then linear, etc. +} + +// linear or quadratic key switch hint +message KSHint { + repeated RqPolynomial hint = 1; + required TypeRep gad = 2; // gadget used for key switching +} + +// information for a single ring switch +message TunnelInfo { + required LinearRq func = 1; // linear function to apply + repeated KSHint hint = 2; + required uint32 e = 3; // index of greatest common subring of r and s + required uint32 r = 4; // input ring index + required uint32 s = 5; // output ring index + required uint64 p = 6; // plaintext modulus +} diff --git a/benchmarks/BenchAppsMain.hs b/benchmarks/BenchAppsMain.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchAppsMain.hs @@ -0,0 +1,125 @@ +{-| +Module : BenchAppsMain +Description : Main driver for lol-apps benchmarks. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Main driver for lol-apps benchmarks. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module BenchAppsMain where + +import Control.Applicative +import Control.Monad.Random + +import Crypto.Lol +import Crypto.Lol.Applications.KeyHomomorphicPRF +import Crypto.Lol.Applications.SymmSHE hiding (CT) +import Crypto.Lol.Benchmarks +import Crypto.Lol.Cyclotomic.Tensor.CPP +import Crypto.Lol.Utils.PrettyPrint.Table +import Crypto.Lol.Types + +import KHPRFBenches +import SHEBenches +import Crypto.Random.DRBG + +infixr 9 ** +data a ** b + +type family Zq (a :: k) :: * where + Zq (a ** b) = (Zq a, Zq b) + Zq q = (ZqBasic q Int64) + +benchNames :: [String] +benchNames = [ + "encrypt", + "decrypt", + "*", + "addPublic", + "mulPublic", + "rescaleCT", + "keySwitch", + "tunnel", + "balanced-startup"] + +main :: IO () +main = do + let o = (defaultOpts Nothing){benches=[]} + pct = Proxy::Proxy CT + bs <- sequence $ + sheBenches' pct (Proxy::Proxy TrivGad) (Proxy::Proxy HashDRBG) ++ + [khprfBenches pct (Proxy::Proxy (BaseBGad 2))] + mapM_ (prettyBenches o) bs + +sheBenches' :: _ => Proxy t -> Proxy gad -> Proxy gen -> [rnd Benchmark] +sheBenches' pt pgad pgen = [ + benchGroup "SHE" $ ($ pt) <$> + [sheBenches (Proxy::Proxy '(F16, F1024, Zq 8, Zq 1017857)) pgen, + sheBenches (Proxy::Proxy '(F16, F2048, Zq 16, Zq 1017857)) pgen], + benchGroup "Dec" $ ($ pt) <$> + [decBenches (Proxy::Proxy '(F16, F1024, Zq 8, Zq 1017857)), + decBenches (Proxy::Proxy '(F16, F2048, Zq 16, Zq 1017857))], + benchGroup "Rescale" $ ($ pt) <$> + [rescaleBenches (Proxy::Proxy '(F32, F2048, Zq 16, Zq 1017857, Zq (1017857 ** 1032193))) pgad, + rescaleBenches (Proxy::Proxy '(F32, F64*F9*F25, Zq 16, Zq 1008001, Zq (1008001 ** 1065601))) pgad], + benchGroup "Tunnel" $ ($ pt) <$> + [tunnelBenches {- H0 -> H1 -} (Proxy::Proxy '(F128, + F128 * F7 * F13, + F64 * F7, F64 * F7 * F13, + Zq PP32, + Zq 3144961)) pgad, + tunnelBenches {- H1 -> H2 -} (Proxy::Proxy '(F64 * F7, + F64 * F7 * F13, + F32 * F7 * F13, + F32 * F7 * F13, + Zq PP32, + Zq 3144961)) pgad, + tunnelBenches {- H2 -> H3 -} (Proxy::Proxy '(F32 * F7 * F13, + F32 * F7 * F13, + F8 * F5 * F7 * F13, + F8 * F5 * F7 *F13, + Zq PP32, + Zq 3144961)) pgad, + tunnelBenches {- H3 -> H4 -} (Proxy::Proxy '(F8 * F5 * F7 * F13, + F8 * F5 * F7 *F13, + F4 * F3 * F5 * F7 * F13, + F4 * F3 * F5 * F7 * F13, + Zq PP32, + Zq 3144961)) pgad, + tunnelBenches {- H4 -> H5 -} (Proxy::Proxy '(F4 * F3 * F5 * F7 * F13, + F4 * F3 * F5 * F7 *F13, + F9 * F5 * F7 * F13, + F9 * F5 * F7 * F13, + Zq PP32, + Zq 3144961)) pgad]] + +khprfBenches :: forall t gad rnd . (_) => Proxy t -> Proxy gad -> rnd Benchmark +khprfBenches pt _ = benchGroup "KHPRF Table" + [benchGroup "left/KHPRF" $ benches' leftSpineTree, + benchGroup "balanced/KHPRF" $ benches' balancedTree, + benchGroup "right/KHPRF" $ benches' rightSpineTree] + where + benches' = khPRFBenches 5 pt (Proxy::Proxy F128) (Proxy::Proxy '(Zq 8, Zq 2, gad)) + +-- EAC: is there a simple way to parameterize the variance? +-- generates a secret key with scaled variance 1.0 +instance (GenSKCtx t m' z Double) => Random (SK (Cyc t m' z)) where + random = runRand $ genSK (1 :: Double) + randomR = error "randomR not defined for SK" diff --git a/benchmarks/KHPRFBenches.hs b/benchmarks/KHPRFBenches.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KHPRFBenches.hs @@ -0,0 +1,74 @@ +{-| +Module : KHPRFBenches +Description : Benchmarks for KeyHomomorphicPRF. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Benchmarks for KeyHomomorphicPRF. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module KHPRFBenches (khPRFBenches) where + +import Control.Applicative +import Control.Monad.Random hiding (fromList) +import Control.Monad.State hiding (state) + +import Crypto.Lol +import Crypto.Lol.Applications.KeyHomomorphicPRF +import Crypto.Lol.Benchmarks + +import MathObj.Matrix hiding (zipWith) + +khPRFBenches :: forall rnd t m zq zp gad . (MonadRandom rnd, _) + => Int -> Proxy t -> Proxy m -> Proxy '(zq,zp,gad) -> (Int -> FullBinTree) -> [rnd Benchmark] +khPRFBenches n _ _ plwe t = + let pcyc = Proxy::Proxy '(t,m,zq,zp,gad) + in [ + genBenchArgs "ring-startup" (benchRingPRF n t [0]) pcyc, + genBenchArgs "ring-amortized" (benchRingPRF n t (grayCode n)) pcyc, + genBenchArgs "lwe-startup" (benchLatticePRF n 3 t [0]) plwe, + genBenchArgs "lwe-amortized" (benchLatticePRF n 3 t (grayCode n)) plwe + ] + +-- benchmarks time to run the PRF on each input, including the time +-- it takes to initialize the state with input 0. +benchRingPRF :: forall t m zq (zp :: *) (gad :: *) . (_) + => Int -> (Int -> FullBinTree) -> [Int] -> Cyc t m zq -> Bench '(t,m,zq,zp,gad) +benchRingPRF size t xs s = benchM $ do + let gadLen = length $ untag (gadget :: Tagged gad [Cyc t m zq]) + a0 <- fromList 1 gadLen <$> take gadLen <$> getRandoms + a1 <- fromList 1 gadLen <$> take gadLen <$> getRandoms + let family = makeFamily a0 a1 (t size) :: PRFFamily gad (Cyc t m zq) (Cyc t m zp) + return $ bench + (let st = prfState family Nothing -- initialize with input 0 + in (flip evalState st . mapM (ringPRFM s))) xs + +-- benchmarks time to run the PRF on each input, including the time +-- it takes to initialize the state with input 0. +benchLatticePRF :: forall (zp :: *) (zq :: *) (gad :: *) . (_) + => Int -> Int -> (Int -> FullBinTree) -> [Int] -> Bench '(zq,zp,gad) +benchLatticePRF size n t xs = benchM $ do + let gadLen = length $ untag (gadget :: Tagged gad [zq]) + a0 :: Matrix zq <- fromList n (n*gadLen) <$> take (gadLen*n*n) <$> getRandoms + a1 :: Matrix zq <- fromList n (n*gadLen) <$> take (gadLen*n*n) <$> getRandoms + s :: Matrix zq <- fromList 1 n <$> take n <$> getRandoms + let family = makeFamily a0 a1 (t size) :: PRFFamily gad zq zp + return $ bench + (let state = prfState family Nothing -- initialize with input 0 + in (flip evalState state . mapM (latticePRFM s))) xs diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs deleted file mode 100644 --- a/benchmarks/Main.hs +++ /dev/null @@ -1,9 +0,0 @@ - -import SHEBenches - -import Criterion.Main - -main :: IO () -main = defaultMain =<< sequence [ - sheBenches - ] diff --git a/benchmarks/SHEBenches.hs b/benchmarks/SHEBenches.hs --- a/benchmarks/SHEBenches.hs +++ b/benchmarks/SHEBenches.hs @@ -1,136 +1,151 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, - TypeOperators #-} +{-| +Module : SHEBenches +Description : Benchmarks for SymmSHE. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX -module SHEBenches (sheBenches) where +Benchmarks for SymmSHE. +-} -import Apply.SHE -import Benchmarks hiding (hideArgs) -import GenArgs -import GenArgs.SHE -import Utils +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module SHEBenches (sheBenches, decBenches, rescaleBenches, tunnelBenches) where + +import Crypto.Lol.Benchmarks + import Control.Applicative import Control.Monad.Random import Control.Monad.State +import Crypto.Lol.Utils.ShowType import Crypto.Random.DRBG import Crypto.Lol import Crypto.Lol.Applications.SymmSHE -import Crypto.Lol.Types hiding (CT) -import qualified Crypto.Lol.Types as CT +import Crypto.Lol.Types +import Crypto.Lol.Types.ZPP -import qualified Criterion as C +addGen5 :: Proxy gen -> Proxy '(t,m,m',zp,zq) -> Proxy '(t,m,m',zp,zq,gen) +addGen5 _ _ = Proxy -hideArgs :: forall a rnd bnch . - (GenArgs (StateT (Maybe (SKOf a)) rnd) bnch, Monad rnd, ShowType a, - ResultOf bnch ~ Bench a) - => bnch -> Proxy a -> rnd Benchmark -hideArgs f p = (C.bench (showType p) . unbench) <$> - (evalStateT (genArgs f) (Nothing :: Maybe (SKOf a))) +addGen6 :: Proxy gad -> Proxy '(t,m,m',zp,zq,zq') -> Proxy '(t,m,m',zp,zq,zq',gad) +addGen6 _ _ = Proxy -sheBenches :: (MonadRandom m) => m Benchmark -sheBenches = benchGroup "SHE" [ - benchGroup "encrypt" $ applyEnc encParams $ hideArgs bench_enc, - benchGroup "decrypt" $ applyDec decParams $ hideArgs bench_dec, - benchGroup "*" $ applyCTFunc ctParams $ hideArgs bench_mul, - benchGroup "addPublic" $ applyCTFunc ctParams $ hideArgs bench_addPublic, - benchGroup "mulPublic" $ applyCTFunc ctParams $ hideArgs bench_mulPublic, - benchGroup "dec" $ applyDec decParams $ hideArgs bench_dec, - benchGroup "rescaleCT" $ applyRescale rescaleParams $ hideArgs bench_rescaleCT, - benchGroup "keySwitch" $ applyKSQ ksqParams $ hideArgs bench_keySwQ, - benchGroup "tunnel" $ applyTunn tunnelParams $ hideArgs bench_tunnel - ] +sheBenches :: forall t m m' zp zq gen rnd . (MonadRandom rnd, _) + => Proxy '(m,m',zp,zq) -> Proxy gen -> Proxy t -> rnd Benchmark +sheBenches _ pgen _ = + let ptmr = Proxy :: Proxy '(t,m,m',zp,zq) + in benchGroup (showType ptmr ++ "/SymmSHE") $ ($ ptmr) <$> [ + genBenchArgs "encrypt" bench_enc . addGen5 pgen, + genBenchArgs "*" bench_mul, + genBenchArgs "addPublic" bench_addPublic, + genBenchArgs "mulPublic" bench_mulPublic + ] -bench_enc :: forall t m m' z zp zq gen . (EncryptCtx t m m' z zp zq, CryptoRandomGen gen, z ~ LiftOf zp, NFElt zp, NFElt zq) +-- zq must be Liftable +decBenches :: forall t m m' zp zq rnd . (MonadRandom rnd, _) + => Proxy '(m,m',zp,zq) -> Proxy t -> rnd Benchmark +decBenches _ _ = + let ptmr = Proxy::Proxy '(t,m,m',zp,zq) + in benchGroup (showType ptmr ++ "/SymmSHE") [genBenchArgs "decrypt" bench_dec ptmr] + +-- must be able to round from zq' to zq +rescaleBenches :: forall t m m' zp zq zq' gad rnd . (MonadRandom rnd, _) + => Proxy '(m,m',zp,zq,zq') -> Proxy gad -> Proxy t -> rnd Benchmark +rescaleBenches _ pgad _ = + let ptmr = Proxy :: Proxy '(t,m,m',zp,zq,zq') + in benchGroup (showType ptmr ++ "/SymmSHE") $ ($ ptmr) <$> [ + genBenchArgs "rescaleCT" bench_rescaleCT, + genBenchArgs "keySwitchQuadCirc" bench_keySwQ . addGen6 pgad] + +tunnelBenches :: forall t r r' s s' zp zq gad rnd . (MonadRandom rnd, _) + => Proxy '(r,r',s,s',zp,zq) -> Proxy gad -> Proxy t -> rnd Benchmark +tunnelBenches _ _ _ = + let ptmr = Proxy :: Proxy '(t,r,r',s,s',zp,zq,gad) + in benchGroup (showType ptmr ++ "/SymmSHE") [genBenchArgs "tunnel" bench_tunnel ptmr] + + +bench_enc :: forall t m m' z zp (zq :: *) (gen :: *) . (z ~ LiftOf zp, _) => SK (Cyc t m' z) -> PT (Cyc t m zp) -> Bench '(t,m,m',zp,zq,gen) bench_enc sk pt = benchIO $ do gen <- newGenIO return $ evalRand (encrypt sk pt :: Rand (CryptoRand gen) (CT m zp (Cyc t m' zq))) gen -bench_mul :: (Ring (CT m zp (Cyc t m' zq)), NFData (CT m zp (Cyc t m' zq))) - => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) -> Bench '(t,m,m',zp,zq) -bench_mul a = bench (*a) - -bench_addPublic :: (AddPublicCtx t m m' zp zq, NFElt zp, NFElt zq) => Cyc t m zp -> CT m zp (Cyc t m' zq) -> Bench '(t,m,m',zp,zq) -bench_addPublic a ct = bench (addPublic a) ct - -bench_mulPublic :: (MulPublicCtx t m m' zp zq, NFElt zp, NFElt zq) => Cyc t m zp -> CT m zp (Cyc t m' zq) -> Bench '(t,m,m',zp,zq) -bench_mulPublic a ct = bench (mulPublic a) ct - -- requires zq to be Liftable -bench_dec :: (DecryptCtx t m m' z zp zq, NFElt zp) - => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> Bench '(t,m,m',zp,zq) -bench_dec sk ct = bench (decrypt sk) ct - -bench_rescaleCT :: forall t m m' zp zq zq' . - (RescaleCyc (Cyc t) zq' zq, ToSDCtx t m' zp zq', NFData (CT m zp (Cyc t m' zq))) - => CT m zp (Cyc t m' zq') -> Bench '(t,m,m',zp,zq,zq') -bench_rescaleCT = bench (rescaleLinearCT :: CT m zp (Cyc t m' zq') -> CT m zp (Cyc t m' zq)) - -bench_keySwQ :: (Ring (CT m zp (Cyc t m' zq)), NFData (CT m zp (Cyc t m' zq))) - => KSHint m zp t m' zq gad zq' -> CT m zp (Cyc t m' zq) -> Bench '(t,m,m',zp,zq,zq',gad) -bench_keySwQ (KeySwitch kswq) x = bench kswq $ x*x - -bench_tunnel :: (NFData (CT s zp (Cyc t s' zq))) - => Tunnel t r r' s s' zp zq gad -> CT r zp (Cyc t r' zq) -> Bench '(t,r,r',s,s',zp,zq,gad) -bench_tunnel (Tunnel f) x = bench f x - -type Gens = '[HashDRBG] -type Gadgets = '[TrivGad, BaseBGad 2] -type Tensors = '[CT.CT,RT] -type MM'PQCombos = - '[ '(F4, F128, Zq 64, Zq 257), - '(F4, F128, Zq 64, Zq (257 ** 641)), - '(F12, F32 * F9, Zq 64, Zq 577), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153)), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153 ** 2017)), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153 ** 2017 ** 2593)), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169)), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169 ** 3457)), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169 ** 3457 ** 6337)), - '(F12, F32 * F9, Zq 64, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169 ** 3457 ** 6337 ** 7489)), - '(F12, F32 * F9 * F25, Zq 64, Zq 14401), - '(F12, F32 * F9 * F25, Zq 64, Zq (14401 ** 21601)) - ] - -type CTParams = ( '(,) <$> Tensors) <*> MM'PQCombos -ctParams :: Proxy CTParams -ctParams = Proxy - -type DecParams = ( '(,) <$> Tensors) <*> (Nub (Filter Liftable MM'PQCombos)) -decParams :: Proxy DecParams -decParams = Proxy +bench_dec :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) -> SK (Cyc t m' z) -> Bench '(t,m,m',zp,zq) +bench_dec pt sk = benchM $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + return $ bench (decrypt sk) ct -type RescaleParams = ( '(,) <$> Tensors) <*> (Map AddZq (Filter NonLiftable MM'PQCombos)) -rescaleParams :: Proxy RescaleParams -rescaleParams = Proxy +bench_mul :: forall t m m' z zp zq . (z ~ LiftOf zp, LiftOf zp ~ ModRep zp, _) + => PT (Cyc t m zp) -> PT (Cyc t m zp) -> SK (Cyc t m' z) -> (Bench '(t,m,m',zp,zq)) +bench_mul pta ptb sk = benchM $ do + a :: CT m zp (Cyc t m' zq) <- encrypt sk pta + b <- encrypt sk ptb + return $ bench (*a) b -type KSQParams = ( '(,) <$> Gadgets) <*> RescaleParams -ksqParams :: Proxy KSQParams -ksqParams = Proxy +bench_addPublic :: forall t m m' z zp zq . (z ~ LiftOf zq, _) + => Cyc t m zp -> PT (Cyc t m zp) -> SK (Cyc t m' z) -> Bench '(t,m,m',zp,zq) +bench_addPublic a pt sk = benchM $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + return $ bench (addPublic a) ct -type EncParams = ( '(,) <$> Gens) <*> CTParams -encParams :: Proxy EncParams -encParams = Proxy +bench_mulPublic :: forall t m m' z zp zq . (z ~ LiftOf zq, _) + => Cyc t m zp -> PT (Cyc t m zp) -> SK (Cyc t m' z) -> Bench '(t,m,m',zp,zq) +bench_mulPublic a pt sk = benchM $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + return $ bench (mulPublic a) ct --- 3144961,5241601,7338241,9959041,10483201,11531521,12579841,15200641,18869761,19393921 -type TunnParams = - ( '(,) <$> Gadgets) <*> - (( '(,) <$> Tensors) <*> - (( '(,) <$> TunnRings) <*> TunnMods)) -tunnelParams :: Proxy TunnParams -tunnelParams = Proxy +bench_rescaleCT :: forall t m m' z zp (zq :: *) (zq' :: *) . (z ~ LiftOf zq, _) + => PT (Cyc t m zp) -> SK (Cyc t m' z) -> Bench '(t,m,m',zp,zq,zq') +bench_rescaleCT pt sk = benchM $ do + ct <- encrypt sk pt + return $ bench (rescaleLinearCT :: CT m zp (Cyc t m' zq') -> CT m zp (Cyc t m' zq)) ct -type TunnRings = '[ - {- H0 -> H1 -} '(F128, F128 * F7 * F13, F64 * F7, F64 * F7 * F13), - {- H1 -> H2 -} '(F64 * F7, F64 * F7 * F13, F32 * F7 * F13, F32 * F7 * F13), - {- H2 -> H3 -} '(F32 * F7 * F13, F32 * F7 * F13, F8 * F5 * F7 * F13, F8 * F5 * F7 *F13), - {- H3 -> H4 -} '(F8 * F5 * F7 * F13, F8 * F5 * F7 *F13, F4 * F3 * F5 * F7 * F13, F4 * F3 * F5 * F7 * F13), - {- H4 -> H5 -} '(F4 * F3 * F5 * F7 * F13, F4 * F3 * F5 * F7 *F13, F9 * F5 * F7 * F13, F9 * F5 * F7 * F13) - ] +bench_keySwQ :: forall t m m' z zp zq (zq' :: *) (gad :: *) . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) -> SK (Cyc t m' z) -> Bench '(t,m,m',zp,zq,zq',gad) +bench_keySwQ pt sk = benchM $ do + x :: CT m zp (Cyc t m' zq) <- encrypt sk pt + ksqHint :: KSQuadCircHint gad (Cyc t m' zq') <- ksQuadCircHint sk + let y = x*x + return $ bench (keySwitchQuadCirc ksqHint) y -type TunnMods = '[ - '(Zq PP32, Zq 3144961) - ] +-- possible bug: If I enable -XPartialTypeSigs and add a ",_" to the constraint list below, GHC +-- can't figure out that `e `Divides` s`, even when it's explicitly listed! +bench_tunnel :: forall t e e' r r' s s' z zp zq gad . + (z ~ LiftOf zp, + GenTunnelInfoCtx t e r s e' r' s' z zp zq gad, + TunnelCtx t r s e' r' s' zp zq gad, + e ~ FGCD r s, + ZPP zp, Mod zp, + z ~ ModRep zp, + r `Divides` r', + Fact e, + NFData zp, + CElt t (ZpOf zp)) + => PT (Cyc t r zp) -> SK (Cyc t r' z) -> SK (Cyc t s' z) -> Bench '(t,r,r',s,s',zp,zq,gad) +bench_tunnel pt skin skout = benchM $ do + x <- encrypt skin pt + let crts :: [Cyc t s zp] = proxy crtSet (Proxy::Proxy e) \\ gcdDivides (Proxy::Proxy r) (Proxy::Proxy s) + r = proxy totientFact (Proxy::Proxy r) + e = proxy totientFact (Proxy::Proxy e) + dim = r `div` e + -- only take as many crts as we need + -- otherwise linearDec fails + linf :: Linear t zp e r s = linearDec (take dim crts) \\ gcdDivides (Proxy::Proxy r) (Proxy::Proxy s) + hints :: TunnelInfo gad t e r s e' r' s' zp zq <- tunnelInfo linf skout skin + return $ bench (tunnelCT hints :: CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq)) x diff --git a/examples/HomomPRFMain.hs b/examples/HomomPRFMain.hs new file mode 100644 --- /dev/null +++ b/examples/HomomPRFMain.hs @@ -0,0 +1,185 @@ +{-| +Module : HomomPRFMain +Description : Example, test, and macro-benchmark for homomorphic evaluation of a PRF. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Example, test, and macro-benchmark for homomorphic evaluation of a PRF. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module HomomPRFMain where + +import Control.DeepSeq +import Control.Monad.Except +import Control.Monad.Random +import Control.Monad.Reader +import Control.Monad.State + +import Crypto.Lol hiding (lift) +import Crypto.Lol.Applications.HomomPRF +import Crypto.Lol.Applications.KeyHomomorphicPRF +import Crypto.Lol.Applications.SymmSHE +import Crypto.Lol.Cyclotomic.Tensor.CPP as CPP +import Crypto.Lol.Types.Proto +import Crypto.Lol.Types.Random +import Crypto.Random.DRBG + +import Data.Promotion.Prelude +import Data.Time.Clock +import Data.Typeable +import MathObj.Matrix (columns) +import System.FilePath ((), pathSeparator) +import System.IO +import Text.Printf + +import HomomPRFParams + +type T = CPP.CT +type Z = Int64 + +protoDir :: Int -> String -> String +protoDir p = (((pathSeparator : "home") "eric" "Desktop" "Lol" ("p" ++ show p ++ "-")) ++) + +lfuncPath, thintPath, rhintPath, tskPath, rskPath :: Int -> String +thintPath p = protoDir p "tunnel.hint" +rhintPath p = protoDir p "round.hint" +lfuncPath p = protoDir p "tunnelfuncs.lfuns" +-- | The key used as the input to tunneling; also used for encryption +tskPath p = protoDir p "encKey.secret" +-- | The output key of tunneling, used for rounding; also for decryption +rskPath p = protoDir p "decKey.secret" + +-- R' - ... - S' +-- | - | - | +-- R - ... - S +-- PRF evaluation usually goes from R' to R. Homomorphic evaluation +-- goes from R' to S, via S'. To test, we run the computation in the clear +-- from R' to R, then tunnel in the clear to S. +main :: IO () +main = do + putStrLn $ "Starting homomorphic PRF evaluation with tensor " ++ show (typeRep (Proxy::Proxy T)) + hints' <- runExceptT readHints + (lfuns, hints :: EvalHints T RngList Z ZP ZQ ZQSeq KSGad, encKey, decKey) <- case hints' of + (Right a) -> do + putStrLn "Using precomputed hints." + return a + (Left st) -> do + putStrLn $ "Could not read precomputed hints: " ++ st + gen :: CryptoRand HashDRBG <- liftIO newGenIO -- uses system entropy + (lfuns, hints, encKey, decKey) <- time "Generating hints..." $ flip evalRand gen $ do + let v = 1.0 :: Double + encKey <- genSK v + (tHints, decKey) <- tunnelInfoChain encKey + let lfuns = ptTunnelFuncs + rHints <- roundHints decKey + let hints = Hints tHints rHints + return (lfuns, hints, encKey, decKey) + writeHints lfuns hints encKey decKey + return (lfuns, hints, encKey, decKey) + gen :: CryptoRand HashDRBG <- liftIO newGenIO -- uses system entropy + (family, s, ct) <- time "Generating random inputs..." $ flip evalRand gen $ do + family :: PRFFamily PRFGad _ _ <- randomFamily 10 -- works on 10-bit input + s <- getRandom + ct <- encrypt encKey s + return (family, s, ct) + st <- time "Initializing PRF state..." $ prfState family Nothing --initialize with input 0 + encprf <- time "Evaluating PRF..." $ flip runReader hints $ flip evalStateT st $ homomPRFM ct 0 + hprf <- time "Decrypting PRF output..." $ decrypt decKey encprf + + -- test + clearPRF <- time "In-the-clear PRF..." $ head $ head $ columns $ ringPRF s 0 st -- homomPRF only computes first elt + clearPRF' <- time "In-the-clear tunnel..." $ ptTunnel lfuns clearPRF + if clearPRF' == hprf + then putStrLn "PASS: Homomorphic output matches in-the-clear." + else putStrLn "TEST FAILED" + +readHints :: forall mon t rngs z e zp zq zqs gad r' s' . + (MonadIO mon, MonadError String mon, Mod zp, UnPP (CharOf zp) ~ '(Prime2, e), + ProtoReadable (TunnelFuncs t (PTRings rngs) (TwoOf zp)), + ProtoReadable (TunnelInfoChain gad t rngs zp (ZqUp zq zqs)), + ProtoReadable (RoundHints t (Fst (Last rngs)) (Snd (Last rngs)) z e zp (ZqDown zq zqs) zqs gad), + ProtoReadable (SK (Cyc t r' z)), ProtoReadable (SK (Cyc t s' z))) + => mon (TunnelFuncs t (PTRings rngs) (TwoOf zp), + EvalHints t rngs z zp zq zqs gad, + SK (Cyc t r' z), SK (Cyc t s' z)) +readHints = do + let p = fromIntegral $ proxy modulus (Proxy::Proxy zp) + lfuns <- parseProtoFile $ lfuncPath p + tHints <- parseProtoFile $ thintPath p + rHints <- parseProtoFile $ rhintPath p + tsk <- parseProtoFile $ tskPath p + rsk <- parseProtoFile $ rskPath p + return (lfuns, Hints tHints rHints, tsk, rsk) +{- +readOrGenHints :: (MonadIO mon, MonadRandom mon, Head RngList ~ '(r,r'), Last RngList ~ '(s,s')) + => mon (EvalHints T RngList Z ZP ZQ ZQSeq KSGad, SK (Cyc T r' Z), SK (Cyc T s' Z)) +readOrGenHints = do + res <- runExceptT readHints + case res of + (Left st) -> do + liftIO $ putStrLn $ "Could not read precomputed data. Error was: " ++ st + (hints, sk, skout) <- do + + liftIO $ putStrLn "Writing hints to disk..." + writeHints hints sk skout + return (hints, sk, skout) + (Right a) -> do + liftIO $ putStrLn "Precomputed hints found." + return a +-} +writeHints :: forall mon t rngs z e zp zq zqs gad r' s' . + (MonadIO mon, Mod zp, UnPP (CharOf zp) ~ '(Prime2, e), + ProtoReadable (TunnelFuncs t (PTRings rngs) (TwoOf zp)), + ProtoReadable (TunnelInfoChain gad t rngs zp (ZqUp zq zqs)), + ProtoReadable (RoundHints t (Fst (Last rngs)) (Snd (Last rngs)) z e zp (ZqDown zq zqs) zqs gad), + ProtoReadable (SK (Cyc t r' z)), ProtoReadable (SK (Cyc t s' z))) + => TunnelFuncs t (PTRings rngs) (TwoOf zp) + -> EvalHints t rngs z zp zq zqs gad + -> SK (Cyc t r' z) + -> SK (Cyc t s' z) + -> mon () +writeHints lfuns (Hints tHints rHints) encKey decKey = do + let p = fromIntegral $ proxy modulus (Proxy::Proxy zp) + writeProtoFile (lfuncPath p) lfuns + writeProtoFile (thintPath p) tHints + writeProtoFile (rhintPath p) rHints + writeProtoFile (tskPath p) encKey + writeProtoFile (rskPath p) decKey + +-- timing functionality +time :: (NFData a) => String -> a -> IO a +time s m = do + putStr' s + wallStart <- getCurrentTime + m `deepseq` printTimes wallStart 1 + return m + +-- flushes the print buffer +putStr' :: String -> IO () +putStr' str = do + putStr str + hFlush stdout + +printTimes :: UTCTime -> Int -> IO () +printTimes wallStart iters = do + wallEnd <- getCurrentTime + let wallTime = realToFrac $ diffUTCTime wallEnd wallStart :: Double + printf "Wall time: %0.3fs" wallTime + if iters == 1 + then putStr "\n\n" + else printf "\tAverage wall time: %0.3fs\n\n" $ wallTime / fromIntegral iters diff --git a/examples/HomomPRFParams.hs b/examples/HomomPRFParams.hs new file mode 100644 --- /dev/null +++ b/examples/HomomPRFParams.hs @@ -0,0 +1,55 @@ +{-| +Module : HomomPRFParams +Description : Parameters for homomorphic PRF. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Parameters for homomorphic PRF. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +module HomomPRFParams (RngList, Zq, ZQSeq, ZP, ZQ, KSGad, PRFGad) where + +import Crypto.Lol +import Crypto.Lol.Types + +type H0 = F128 +type H1 = F64 * F7 +type H2 = F32 * F7 * F13 +type H3 = F8 * F5 * F7 * F13 +type H4 = F4 * F3 * F5 * F7 * F13 +type H5 = F9 * F5 * F7 * F13 +type H0' = H0 * F7 * F13 +type H1' = H1 * F13 +type H2' = H2 +type H3' = H3 +type H4' = H4 +type H5' = H5 +type RngList = '[ '(H0,H0'), '(H1,H1'), '(H2,H2'), '(H3,H3'), '(H4,H4'), '(H5,H5') ] + +type Zq (q :: k) = ZqBasic q Int64 +-- three 24-bit moduli, enough to handle rounding for p=32 (depth-4 circuit at ~17 bits per mul) +type ZQ1 = Zq 18869761 +type ZQ2 = (Zq 19393921, ZQ1) +type ZQ3 = (Zq 19918081, ZQ2) +type ZQ4 = (Zq 25159681, ZQ3) +-- a 31-bit modulus, for rounding off after the last four hops +type ZQ5 = (Zq 2149056001, ZQ4) +-- for rounding off after the first hop +type ZQ6 = (Zq 3144961, ZQ5) +type ZQ7 = (Zq 7338241, ZQ6) +type ZQSeq = '[ZQ7, ZQ6, ZQ5, ZQ4, ZQ3, ZQ2, ZQ1] + +type ZP = Zq PP8 +type ZQ = ZQ4 -- if p=2^k, choose ZQ[k+1] + +-- these need not be the same +type KSGad = BaseBGad 2 +type PRFGad = BaseBGad 2 diff --git a/examples/KHPRFMain.hs b/examples/KHPRFMain.hs new file mode 100644 --- /dev/null +++ b/examples/KHPRFMain.hs @@ -0,0 +1,67 @@ +{-| +Module : KHPRFMain +Description : Example using KeyHomomorphicPRF. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Example using KeyHomomorphicPRF. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module KHPRFMain where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad.Random hiding (fromList) +import Control.Monad.State hiding (state) + +import Crypto.Lol +import Crypto.Lol.Applications.KeyHomomorphicPRF +import Crypto.Lol.Cyclotomic.Tensor.CPP +import Crypto.Lol.Types + +import MathObj.Matrix hiding (zipWith) + +type Zq q = ZqBasic q Int64 +type Cyclo m q = Cyc CT m (Zq q) +type Gad = BaseBGad 2 +type M = F128 + +type Cyclo' q = Cyclo M q + +main :: IO () +main = do + family :: PRFFamily Gad (Cyclo' 257) (Cyclo M 32) <- randomFamily 10 -- works on 10-bit input + s <- getRandom -- prf seed + let state = prfState family Nothing -- initialize with input 0 + prf = ringPRFM s + xs = grayCode 3 + res = map rows $ flip evalState state $ mapM prf xs + res `deepseq` print "done" + +main2 :: IO () +main2 = do + let n = 3 -- 3 rows/matrix + k = 10 -- 10 bit input + t = balancedTree k + gadLen = 9 + a0 <- fromList n (n*gadLen) <$> take (gadLen*n*n) <$> getRandoms + a1 <- fromList n (n*gadLen) <$> take (gadLen*n*n) <$> getRandoms + let family = makeFamily a0 a1 t :: PRFFamily Gad (Zq 257) (Zq 32) + s <- fromList 1 n <$> take n <$> getRandoms + let state = prfState family Nothing -- initialize with input 0 + prf x = latticePRFM s x + xs = grayCode 3 + res = map rows $ flip evalState state $ mapM prf xs + print res diff --git a/examples/SHEMain.hs b/examples/SHEMain.hs new file mode 100644 --- /dev/null +++ b/examples/SHEMain.hs @@ -0,0 +1,95 @@ +{-| +Module : SHEMain +Description : Example using SymmSHE. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Example using SymmSHE. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module SHEMain where + +import Crypto.Lol hiding ((^)) +import Crypto.Lol.Applications.SymmSHE -- exports *ciphertext* 'CT' +import Crypto.Lol.Types +import qualified Crypto.Lol.Cyclotomic.Tensor.CPP as C -- the *tensor* 'CT' + +import Algebra.Ring ((^)) + +import Control.Monad.Random (getRandom) + +-- PTIndex must divide CTIndex +type PTIndex = F128 + +-- Crypto.Lol includes Factored types F1..F512 +-- for cyclotomic indices outside this range, +-- we provide a TH wrapper. +-- TH to constuct the cyclotomic index 11648 +type CTIndex = $(fType $ 2^7 * 7 * 13) + +-- To use crtSet (for example, when ring switching), the plaintext +-- modulus must be a PrimePower (ZPP constraint). Crypto.Lol exports +-- (via Crypto.Lol.Factored) PP2,PP4,...,PP128, as well as some prime +-- powers for 3,5,7, and 11. Alternately, an arbitrary prime power +-- p^e can be constructed with the Template Haskell splice $(ppType +-- (p,e)). For applications that don't use crtSet, the PT modulus can +-- be a TypeLit. +type PTZq = ZqBasic PP8 Int64 + +-- uses GHC.TypeLits as modulus, and Int64 as underyling +-- representation (needed to use with CT backend). The modulus +-- doesn't have to be "good", but "good" moduli are faster. +type Zq q = ZqBasic q Int64 -- uses PolyKinds +type CTZq1 = Zq 536937857 +type CTZq2 = (CTZq1, Zq 536972801) +type CTZq3 = (CTZq2, Zq 537054337) + +-- Tensor backend, either Repa (RT) or C (CT) +type T = C.CT -- can also use RT + +type KSGad = TrivGad -- can also use (BaseBGad 2), for example + +type PTRing = Cyc T PTIndex PTZq +type CTRing1 = CT PTIndex PTZq (Cyc T CTIndex CTZq1) +type CTRing2 = CT PTIndex PTZq (Cyc T CTIndex CTZq2) +type SKRing = Cyc T CTIndex (LiftOf PTZq) + +main :: IO () +main = do + plaintext <- getRandom + sk :: SK SKRing <- genSK (1 :: Double) + -- encrypt with a single modulus + ciphertext :: CTRing1 <- encrypt sk plaintext + + let ct1 = 2*ciphertext + pt1 = decrypt sk ct1 + print $ "Test1: " ++ (show $ 2*plaintext == pt1) + + hint :: KSQuadCircHint KSGad (Cyc T CTIndex CTZq2) <- ksQuadCircHint sk + let ct2 = keySwitchQuadCirc hint $ ciphertext*ciphertext + pt2 = decrypt sk ct2 + -- note: this requires a *LARGE* CT modulus to succeed + print $ "Test2: " ++ (show $ plaintext*plaintext == pt2) + + -- so we support using *several* small moduli: + hint' :: KSQuadCircHint KSGad (Cyc T CTIndex CTZq3) <- ksQuadCircHint sk + ciphertext' :: CTRing2 <- encrypt sk plaintext + let ct3 = keySwitchQuadCirc hint' $ ciphertext' * ciphertext' + -- the CT modulus of ct3 is a ring product, which can't be lifted to a fixed size repr + -- so use decryptUnrestricted instead + pt3 = decryptUnrestricted sk ct3 + ct3' = rescaleLinearCT ct3 :: CTRing1 + -- after rescaling, ct3' has a single modulus, so we can use normal decrypt + pt3' = decrypt sk ct3' + print $ "Test3: " ++ (show $ (plaintext*plaintext == pt3) && (pt3' == pt3)) + diff --git a/examples/SymmSHE/SimpleSHE.hs b/examples/SymmSHE/SimpleSHE.hs deleted file mode 100644 --- a/examples/SymmSHE/SimpleSHE.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -import Crypto.Lol hiding ((^)) -import Crypto.Lol.Applications.SymmSHE -- exports *ciphertext* 'CT' -import Crypto.Lol.Types hiding (CT) -import qualified Crypto.Lol.Types as C -- the *tensor* 'CT' - -import Algebra.Ring ((^)) - -import Control.Monad.Random (getRandom) - --- PTIndex must divide CTIndex -type PTIndex = F128 - --- Crypto.Lol includes Factored types F1..F512 --- for cyclotomic indices outside this range, --- we provide a TH wrapper. --- TH to constuct the cyclotomic index 11648 -type CTIndex = $(fType $ 2^7 * 7 * 13) - --- To use crtSet (for example, when ring switching), the plaintext --- modulus must be a PrimePower (ZPP constraint). Crypto.Lol exports --- (via Crypto.Lol.Factored) PP2,PP4,...,PP128, as well as some prime --- powers for 3,5,7, and 11. Alternately, an arbitrary prime power --- p^e can be constructed with the Template Haskell splice $(ppType --- (p,e)). For applications that don't use crtSet, the PT modulus can --- be a TypeLit. -type PTZq = ZqBasic PP8 Int64 - --- uses GHC.TypeLits as modulus, and Int64 as underyling --- representation (needed to use with CT backend). The modulus --- doesn't have to be "good", but "good" moduli are faster. -type Zq q = ZqBasic q Int64 -- uses PolyKinds -type CTZq1 = Zq 536937857 -type CTZq2 = (CTZq1, Zq 536972801) -type CTZq3 = (CTZq2, Zq 537054337) - --- Tensor backend, either Repa (RT) or C (CT) -type T = C.CT -- can also use RT - -type KSGad = TrivGad -- can also use (BaseBGad 2), for example - -type PTRing = Cyc T PTIndex PTZq -type CTRing1 = CT PTIndex PTZq (Cyc T CTIndex CTZq1) -type CTRing2 = CT PTIndex PTZq (Cyc T CTIndex CTZq2) -type SKRing = Cyc T CTIndex (LiftOf PTZq) - -main :: IO () -main = do - plaintext <- getRandom - sk :: SK SKRing <- genSK (1 :: Double) - -- encrypt with a single modulus - ciphertext :: CTRing1 <- encrypt sk plaintext - - let ct1 = 2*ciphertext - pt1 = decrypt sk ct1 - print $ "Test1: " ++ (show $ 2*plaintext == pt1) - - kswq <- proxyT (keySwitchQuadCirc sk) (Proxy::Proxy (KSGad, CTZq2)) - let ct2 = kswq $ ciphertext*ciphertext - pt2 = decrypt sk ct2 - -- note: this requires a *LARGE* CT modulus to succeed - print $ "Test2: " ++ (show $ plaintext*plaintext == pt2) - - -- so we support using *several* small moduli: - kswq' <- proxyT (keySwitchQuadCirc sk) (Proxy::Proxy (KSGad, CTZq3)) - ciphertext' :: CTRing2 <- encrypt sk plaintext - let ct3 = kswq' $ ciphertext' * ciphertext' - -- the CT modulus of ct3 is a ring product, which can't be lifted to a fixed size repr - -- so use decryptUnrestricted instead - pt3 = decryptUnrestricted sk ct3 - ct3' = rescaleLinearCT ct3 :: CTRing1 - -- after rescaling, ct3' has a single modulus, so we can use normal decrypt - pt3' = decrypt sk ct3' - print $ "Test3: " ++ (show $ (plaintext*plaintext == pt3) && (pt3' == pt3)) - diff --git a/lol-apps.cabal b/lol-apps.cabal --- a/lol-apps.cabal +++ b/lol-apps.cabal @@ -5,7 +5,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Lattice-based cryptographic applications using Lol. homepage: https://github.com/cpeikert/Lol Bug-Reports: https://github.com/cpeikert/Lol/issues @@ -17,21 +17,11 @@ category: Crypto stability: experimental build-type: Simple -extra-source-files: README, CHANGES.md, - benchmarks/SHEBenches.hs, - tests/SHETests.hs, - utils/Apply.hs, - utils/Apply/SHE.hs - utils/Benchmarks.hs, - utils/GenArgs.hs, - utils/GenArgs/SHE.hs - utils/Tests.hs, - utils/TestTypes.hs, - utils/Utils.hs +extra-source-files: README, CHANGES.md, SHE.proto, HomomPRF.proto cabal-version: >= 1.10 description: This library contains example cryptographic applications built using - (Lol), + (Lol), a general-purpose library for ring-based lattice cryptography. source-repository head @@ -61,46 +51,71 @@ ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 exposed-modules: + Crypto.Lol.Applications.HomomPRF + Crypto.Lol.Applications.KeyHomomorphicPRF Crypto.Lol.Applications.SymmSHE + Crypto.Proto.HomomPRF + Crypto.Proto.HomomPRF.LinearFuncChain + Crypto.Proto.HomomPRF.RoundHintChain + Crypto.Proto.HomomPRF.TunnelInfoChain + Crypto.Proto.SHE + Crypto.Proto.SHE.KSHint + Crypto.Proto.SHE.RqPolynomial + Crypto.Proto.SHE.SecretKey + Crypto.Proto.SHE.TunnelInfo build-depends: - base>=4.8 && <5, - deepseq >= 1.4.1.1 && <1.5, - lol >= 0.3 && < 0.5, - MonadRandom >= 0.2 && < 0.5, - numeric-prelude >= 0.4.2 && < 0.5 + base >= 4.9 && < 5, + containers, + deepseq >= 1.4.1.1, + lol >= 0.6.0.0, + MonadRandom >= 0.2, + mtl, + numeric-prelude >= 0.4.2, + protocol-buffers, + protocol-buffers-descriptor, + singletons, + split test-suite test-apps type: exitcode-stdio-1.0 - hs-source-dirs: tests,utils + hs-source-dirs: tests, examples default-language: Haskell2010 - main-is: Main.hs + main-is: TestAppsMain.hs + ghc-options: -main-is TestAppsMain + other-modules: KHPRFTests, SHETests - ghc-options: -threaded -rtsopts + ghc-options: -threaded -rtsopts build-depends: arithmoi, - base, + base >= 4.9 && < 5, constraints, deepseq, DRBG, - lol, + lol >= 0.6.0.0, lol-apps, + lol-cpp, + lol-repa, + lol-tests, MonadRandom, mtl, - QuickCheck >= 2.8 && < 2.9, + numeric-prelude, + QuickCheck >= 2.8, random, repa, singletons, - test-framework >= 0.8 && < 0.9, - test-framework-quickcheck2 >= 0.3 && < 0.4, + test-framework >= 0.8, + test-framework-quickcheck2 >= 0.3, vector Benchmark bench-apps type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks,utils + hs-source-dirs: benchmarks, examples default-language: Haskell2010 - main-is: Main.hs + main-is: BenchAppsMain.hs + ghc-options: -main-is BenchAppsMain + other-modules: KHPRFBenches, SHEBenches -- if flag(llvm) -- ghc-options: -fllvm -optlo-O3 @@ -110,30 +125,80 @@ build-depends: arithmoi, - base, + base >= 4.9 && < 5, + containers, criterion, deepseq, DRBG, - lol, + lol >= 0.6.0.0, lol-apps, + lol-benches, + lol-cpp, + lol-repa, MonadRandom, mtl, + numeric-prelude, singletons, transformers, vector, repa -executable simpleSHE - hs-source-dirs: examples/SymmSHE, utils +executable homomprf + hs-source-dirs: examples default-language: Haskell2010 - main-is: SimpleSHE.hs + main-is: HomomPRFMain.hs + ghc-options: -main-is HomomPRFMain + other-modules: HomomPRFParams ghc-options: -threaded -rtsopts build-depends: arithmoi, - base, - lol, + base >= 4.9 && < 5, + deepseq, + DRBG, + filepath, + lol >= 0.6.0.0, lol-apps, + lol-cpp, + MonadRandom, + mtl, + numeric-prelude, + singletons, + time + +executable khprf + hs-source-dirs: examples + default-language: Haskell2010 + main-is: KHPRFMain.hs + ghc-options: -main-is KHPRFMain + + ghc-options: -threaded -rtsopts + + build-depends: + arithmoi, + base >= 4.9 && < 5, + deepseq, + lol >= 0.6.0.0, + lol-apps, + lol-cpp, + MonadRandom, + mtl, + numeric-prelude + +executable symmshe + hs-source-dirs: examples + default-language: Haskell2010 + main-is: SHEMain.hs + ghc-options: -main-is SHEMain + + ghc-options: -threaded -rtsopts + + build-depends: + arithmoi, + base >= 4.9 && < 5, + lol >= 0.6.0.0, + lol-apps, + lol-cpp, MonadRandom, numeric-prelude diff --git a/tests/KHPRFTests.hs b/tests/KHPRFTests.hs new file mode 100644 --- /dev/null +++ b/tests/KHPRFTests.hs @@ -0,0 +1,63 @@ +{-| +Module : KHPRFTests +Description : Tests for KeyHomomorphicPRF. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Tests for KeyHomomorphicPRF. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module KHPRFTests (khprfTests) where + +import Control.Applicative +import Control.Monad.Random + +import Crypto.Lol +import Crypto.Lol.Applications.KeyHomomorphicPRF +import Crypto.Lol.Cyclotomic.UCyc +import Crypto.Lol.Tests +import Crypto.Lol.Utils.ShowType + +import MathObj.Matrix + +import qualified Test.Framework as TF + +khprfTests :: forall t m zp zq gad . (_) + => Proxy '(m,zp,zq,gad) -> Proxy t -> TF.Test +khprfTests _ _ = + let ptmr = Proxy::Proxy '(t,m,zp,zq,gad) + in testGroup (showType ptmr) $ ($ ptmr) <$> [ + genTestArgs "PRF_3bits" (prop_keyHomom 3), + genTestArgs "PRF_5bits" (prop_keyHomom 5)] + +-- +/-1 in every coefficient of the rounding basis +prop_keyHomom :: forall t m zp zq gad . (Fact m, CElt t zq, CElt t zp, _) + => Int -> Test '(t,m,zp,zq,gad) +prop_keyHomom size = testIO $ do + family :: PRFFamily gad (Cyc t m zq) (Cyc t m zp) <- randomFamily size + s1 <- getRandom + s2 <- getRandom + x <- ((`mod` (2^size)) . abs) <$> getRandom + let s3 = s1+s2 + state = prfState family Nothing + prf1 = ringPRF s1 x state + prf2 = ringPRF s2 x state + prf3 = ringPRF s3 x state + prf3' = prf1+prf2 :: Matrix (Cyc t m zp) + a = uncycPow <$> prf3 + b = uncycPow <$> prf3' + c = concat $ rows $ a - b + c' = map (maximum . fmapPow abs . lift) c + return $ maximum c' <= 1 diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ - -import SHETests - -import Test.Framework - -main :: IO () -main = do - flip defaultMainWithArgs ["--threads=1","--maximum-generated-tests=100"] - [ testGroup "SHE Tests" sheTests - ] diff --git a/tests/SHETests.hs b/tests/SHETests.hs --- a/tests/SHETests.hs +++ b/tests/SHETests.hs @@ -1,312 +1,270 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-| +Module : SHETests +Description : Tests for SymmSHE. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX -module SHETests (sheTests) where +Tests for SymmSHE. +-} -import Apply.SHE -import GenArgs -import GenArgs.SHE -import Tests hiding (hideArgs) -import Utils +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module SHETests (sheTests, decTest, modSwPTTest, ksTests, twemTests, tunnelTests) where + import Control.Applicative import Control.Monad import Control.Monad.Random -import Control.Monad.State import Crypto.Lol import Crypto.Lol.Applications.SymmSHE -import qualified Crypto.Lol.Cyclotomic.Tensor.CTensor as CT -import qualified Crypto.Lol.Cyclotomic.Tensor.RepaTensor as RT +import Crypto.Lol.Tests +import Crypto.Lol.Utils.ShowType import qualified Test.Framework as TF -import Test.Framework.Providers.QuickCheck2 -v :: Double -v = 1 +sheTests :: forall t m m' zp zq . (_) + => Proxy '(m,m',zp,zq) -> Proxy t -> TF.Test +sheTests _ _ = + let ptmr = Proxy::Proxy '(t,m,m',zp,zq) + in testGroup (showType ptmr) $ ($ ptmr) <$> [ + genTestArgs "DecU . Enc" prop_encDecU, + genTestArgs "AddPub" prop_addPub, + genTestArgs "MulScal" prop_mulScal, + genTestArgs "MulPub" prop_mulPub, + genTestArgs "ScalarPub" prop_addScalar, + genTestArgs "CTAdd" prop_ctadd, + genTestArgs "CTAdd2" prop_ctadd2, + genTestArgs "CTMul" prop_ctmul, + genTestArgs "CT zero" prop_ctzero, + genTestArgs "CT one" prop_ctone] -hideArgs :: forall a rnd bnch. - (GenArgs (StateT (Maybe (SKOf a)) rnd) bnch, MonadRandom rnd, - ShowType a, ResultOf bnch ~ Test a) - => bnch -> Proxy a -> rnd TF.Test -hideArgs f p = do - res <- evalStateT (genArgs f) (Nothing :: Maybe (SKOf a)) - case res of - Test b -> return $ testProperty (showType p) b - TestM b -> testProperty (showType p) <$> b +-- zq must be liftable +decTest :: forall t m m' zp zq . (_) + => Proxy '(m,m',zp,zq) -> Proxy t -> TF.Test +decTest _ _ = + let ptmr = Proxy::Proxy '(t,m,m',zp,zq) + in testGroup (showType ptmr) + [genTestArgs "Dec . Enc" prop_encDec ptmr] -sheTests :: [TF.Test] -sheTests = - [testGroupM "Dec . Enc" $ applyDec decParams $ hideArgs prop_encDec, - testGroupM "DecU . Enc" $ applyCTFunc ctParams $ hideArgs prop_encDecU, - testGroupM "AddPub" $ applyCTFunc ctParams $ hideArgs prop_addPub, - testGroupM "MulPub" $ applyCTFunc ctParams $ hideArgs prop_mulPub, - testGroupM "ScalarPub" $ applyCTFunc ctParams $ hideArgs prop_addScalar, - testGroupM "CTAdd" $ applyCTFunc ctParams $ hideArgs prop_ctadd, - testGroupM "CTMul" $ applyCTFunc ctParams $ hideArgs prop_ctmul, - testGroupM "CT zero" $ applyCTFunc ctParams $ hideArgs prop_ctzero, - testGroupM "CT one" $ applyCTFunc ctParams $ hideArgs prop_ctone, - testGroupM "ModSwitch PT" modSwPTTests, - testGroupM "Tunnel" tunnelTests, - testGroupM "Twace" $ applyCTTwEm twoIdxParams $ hideArgs prop_cttwace, - testGroupM "Embed" $ applyCTTwEm twoIdxParams $ hideArgs prop_ctembed, - testGroupM "KSLin" $ applyKSQ ksqParams $ hideArgs prop_ksLin, - testGroupM "keySwitch" $ applyKSQ ksqParams $ hideArgs prop_ksQuad - ] +modSwPTTest :: forall t m m' zp zp' zq . (_) + => Proxy '(m,m',zp,zp',zq) -> Proxy t -> TF.Test +modSwPTTest _ _ = + let ptmr = Proxy::Proxy '(t,m,m',zp,zp',zq) + in testGroup (showType ptmr) + [genTestArgs "ModSwitch PT" prop_modSwPT ptmr] -type CTCombos = '[ - '(F7, F7, Zq 2,Zq (19393921 ** 18869761)), - '(F7, F21,Zq 2,Zq (19393921 ** 18869761)), - '(F2, F8, Zq 2,Zq 536871001), - '(F1, F8, Zq 2,Zq 536871001), - '(F4, F12,Zq 2,Zq 2148249601), - '(F4, F8, Zq 3,Zq 2148249601), - '(F7, F7, Zq 4,Zq (19393921 ** 18869761)), - '(F7, F21,Zq 4,Zq (19393921 ** 18869761)), - '(F1, F4, Zq 4,Zq 18869761), - '(F4, F4, Zq 4,Zq 18869761), - '(F14,F14,Zq 4,Zq 18869761), - '(F28,F28,Zq 4,Zq 18869761), - '(F28,F28,Zq 4,Zq 80221), - '(F1, F8, Zq 4,Zq 536871001), - '(F2, F8, Zq 4,Zq 536871001), - '(F4, F12,Zq 8,Zq 2148249601) - ] +ksTests :: forall t m m' zp zq zq' gad . (_) + => Proxy '(m,m',zp,zq,zq') -> Proxy gad -> Proxy t -> TF.Test +ksTests _ _ _ = + let ptmr = Proxy::Proxy '(t,m,m',zp,zq,zq',gad) + in testGroup (showType ptmr) $ ($ ptmr) <$> [ + genTestArgs "KSLin" prop_ksLin, + genTestArgs "KSQuad" prop_ksQuad] -type Gadgets = '[TrivGad, BaseBGad 2] -type Tensors = '[CT.CT,RT.RT] -type MM'PQCombos = - '[ '(F1, F7, Zq 2, Zq (19393921 ** 18869761)), - '(F2, F4, Zq 8, Zq (2148854401 ** 2148249601)), - '(F4, F12, Zq 2, Zq (2148854401 ** 2148249601)), - '(F8, F64, Zq 2, Zq (2148854401 ** 2148249601)), - '(F3, F27, Zq 2, Zq (2148854401 ** 2148249601)), - '(F2, F4, Zq 8, Zq (2148854401 ** 2148249601 ** 2150668801)), - '(F4, F12, Zq 2, Zq (2148854401 ** 2148249601 ** 2150668801)), - '(F8, F64, Zq 2, Zq (2148854401 ** 2148249601 ** 2150668801)), - '(F3, F27, Zq 2, Zq (2148854401 ** 2148249601 ** 2150668801))] +twemTests :: forall t r r' s s' zp zq . (_) + => Proxy '(r,r',s,s',zp,zq) -> Proxy t -> TF.Test +twemTests _ _ = + let ptmr = Proxy::Proxy '(t,r,r',s,s',zp,zq) + in testGroup (showType ptmr) [ + genTestArgs "Embed" prop_ctembed ptmr, + genTestArgs "Twace" prop_cttwace ptmr] +tunnelTests :: forall t r r' s s' zp zq gad . (_) + => Proxy '(r,r',s,s',zp,zq) -> Proxy gad -> Proxy t -> TF.Test +tunnelTests _ _ _ = + let ptmr = Proxy::Proxy '(t,r,r',s,s',zp,zq,gad) + in testGroup (showType ptmr) + [genTestArgs "Tunnel" prop_ringTunnel ptmr] -type CTParams = ( '(,) <$> Tensors) <*> CTCombos -ctParams :: Proxy CTParams -ctParams = Proxy -type DecParams = ( '(,) <$> Tensors) <*> (Nub (Filter Liftable CTCombos)) -decParams :: Proxy DecParams -decParams = Proxy -type Zq'Params = ( '(,) <$> Tensors) <*> (Map AddZq (Filter NonLiftable MM'PQCombos)) -type KSQParams = ( '(,) <$> Gadgets) <*> Zq'Params -ksqParams :: Proxy KSQParams -ksqParams = Proxy -type TwoIdxParams = ( '(,) <$> Tensors) <*> '[ '(F1, F7, F3, F21, Zq 2, Zq 18869761)] -twoIdxParams :: Proxy TwoIdxParams -twoIdxParams = Proxy -prop_ksLin :: (DecryptUCtx t m m' z zp zq, Eq (Cyc t m zp)) - => KSLinear t m m' z zp zq zq' gad - -> PTCT m zp (Cyc t m' zq) - -> Test '(t,m,m',zp,zq,zq',gad) -prop_ksLin (KSL kswlin skout) (PTCT x' x) = - let y = kswlin x - y' = decryptUnrestricted skout y - in test $ x' == y' +prop_encDecU :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) +prop_encDecU x sk = testIO $ do + y :: CT m zp (Cyc t m' zq) <- encrypt sk x + let x' = decryptUnrestricted sk $ y + return $ x == x' -prop_ksQuad :: (Ring (CT m zp (Cyc t m' zq)), - DecryptUCtx t m m' z zp zq, - Eq (Cyc t m zp)) - => SK (Cyc t m' z) - -> KSHint m zp t m' zq gad zq' - -> PTCT m zp (Cyc t m' zq) - -> PTCT m zp (Cyc t m' zq) - -> Test '(t,m,m',zp,zq,zq',gad) -prop_ksQuad sk (KeySwitch kswq) (PTCT y1 x1) (PTCT y2 x2) = - let x' = kswq $ x1*x2 - y = y1*y2 - x = decryptUnrestricted sk x' - in test $ y == x +prop_addPub :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => Cyc t m zp + -> PT (Cyc t m zp) + -> SK (Cyc t m' z) + -> Test '(t,m,m',zp,zq) +prop_addPub a pt sk = testIO $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + let ct' = addPublic a ct + pt' = decryptUnrestricted sk ct' + return $ pt' == (a+pt) -prop_addPub :: forall t m m' z zp zq . - (DecryptUCtx t m m' z zp zq, - AddPublicCtx t m m' zp zq, - Eq (Cyc t m zp)) - => SK (Cyc t m' z) - -> Cyc t m zp - -> PTCT m zp (Cyc t m' zq) +prop_mulScal :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => zp + -> PT (Cyc t m zp) + -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) -prop_addPub sk x (PTCT y' y) = - let xy = addPublic x y - xy' = decryptUnrestricted sk xy - in test $ xy' == (x+y') +prop_mulScal a pt sk = testIO $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + let ct' = mulScalar a ct + pt' = decryptUnrestricted sk ct' + return $ pt' == ((scalarCyc a) * pt) -prop_mulPub :: (DecryptUCtx t m m' z zp zq, - MulPublicCtx t m m' zp zq, - Eq (Cyc t m zp)) - => SK (Cyc t m' z) - -> Cyc t m zp - -> PTCT m zp (Cyc t m' zq) +prop_mulPub :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => Cyc t m zp + -> PT (Cyc t m zp) + -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) -prop_mulPub sk x (PTCT y' y) = - let xy = mulPublic x y - xy' = decryptUnrestricted sk xy - in test $ xy' == (x*y') +prop_mulPub a pt sk = testIO $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + let ct' = mulPublic a ct + pt' = decryptUnrestricted sk ct' + return $ pt' == (a*pt) -prop_addScalar :: (DecryptUCtx t m m' z zp zq, - AddScalarCtx t m' zp zq, - Eq (Cyc t m zp)) - => SK (Cyc t m' z) -> zp -> PTCT m zp (Cyc t m' zq) -> Test '(t,m,m',zp,zq) -prop_addScalar sk c (PTCT x' x) = - let cx = addScalar c x - cx' = decryptUnrestricted sk cx - in test $ cx' == ((scalarCyc c)+x') +prop_addScalar :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => zp -> PT (Cyc t m zp) -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) +prop_addScalar c pt sk = testIO $ do + ct :: CT m zp (Cyc t m' zq) <- encrypt sk pt + let ct' = addScalar c ct + pt' = decryptUnrestricted sk ct' + return $ pt' == ((scalarCyc c)+pt) -prop_ctadd :: (DecryptUCtx t m m' z zp zq, - Additive (CT m zp (Cyc t m' zq)), - Eq (Cyc t m zp)) - => SK (Cyc t m' z) - -> PTCT m zp (Cyc t m' zq) - -> PTCT m zp (Cyc t m' zq) +prop_ctadd :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) + -> PT (Cyc t m zp) + -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) -prop_ctadd sk (PTCT x1' x1) (PTCT x2' x2) = - let y = x1+x2 - y' = decryptUnrestricted sk y - in test $ x1'+x2' == y' +prop_ctadd pt1 pt2 sk = testIO $ do + ct1 :: CT m zp (Cyc t m' zq) <- encrypt sk pt1 + ct2 :: CT m zp (Cyc t m' zq) <- encrypt sk pt2 + let ct' = ct1 + ct2 + pt' = decryptUnrestricted sk ct' + return $ pt1+pt2 == pt' -prop_ctmul :: (DecryptUCtx t m m' z zp zq, - Ring (CT m zp (Cyc t m' zq)), - Eq (Cyc t m zp)) - => SK (Cyc t m' z) - -> PTCT m zp (Cyc t m' zq) - -> PTCT m zp (Cyc t m' zq) +-- tests adding with different scale values +prop_ctadd2 :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) + -> PT (Cyc t m zp) + -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) -prop_ctmul sk (PTCT x1' x1) (PTCT x2' x2) = - let y = x1*x2 - y' = decryptUnrestricted sk y - in test $ x1'*x2' == y' +prop_ctadd2 pt1 pt2 sk = testIO $ do + ct1 :: CT m zp (Cyc t m' zq) <- encrypt sk pt1 + ct2 :: CT m zp (Cyc t m' zq) <- encrypt sk pt2 + -- no-op to induce unequal scale values + let ct' = ct1 + (modSwitchPT ct2) + pt' = decryptUnrestricted sk ct' + return $ pt1+pt2 == pt' -prop_ctzero :: forall t m m' z zp zq . - (DecryptUCtx t m m' z zp zq, - Additive (CT m zp (Cyc t m' zq)), - Eq (Cyc t m zp)) +prop_ctmul :: forall t m m' z zp zq . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) + -> PT (Cyc t m zp) + -> SK (Cyc t m' z) + -> Test '(t,m,m',zp,zq) +prop_ctmul pt1 pt2 sk = testIO $ do + ct1 :: CT m zp (Cyc t m' zq) <- encrypt sk pt1 + ct2 :: CT m zp (Cyc t m' zq) <- encrypt sk pt2 + let ct' = ct1 * ct2 + pt' = decryptUnrestricted sk ct' + return $ pt1*pt2 == pt' + +prop_ctzero :: forall t m m' z zp (zq :: *) . (z ~ LiftOf zp, Fact m, _) => SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) prop_ctzero sk = let z = decryptUnrestricted sk (zero :: CT m zp (Cyc t m' zq)) in test $ zero == z -prop_ctone :: forall t m m' z zp zq . - (DecryptUCtx t m m' z zp zq, - Ring (CT m zp (Cyc t m' zq)), - Eq (Cyc t m zp)) +prop_ctone :: forall t m m' z zp (zq :: *) . (z ~ LiftOf zp, Fact m, _) => SK (Cyc t m' z) -> Test '(t,m,m',zp,zq) prop_ctone sk = - let z = decryptUnrestricted sk (one :: CT m zp (Cyc t m' zq)) + let z = decryptUnrestricted sk (one :: CT m zp (Cyc t m' zq)) :: Cyc t m zp in test $ one == z -prop_ctembed :: forall t r r' s s' z zp zq . - (DecryptUCtx t r r' z zp zq, - DecryptUCtx t s s' z zp zq, - r `Divides` s, - r' `Divides` s', - Eq (Cyc t s zp)) - => SK (Cyc t r' z) -> PTCT r zp (Cyc t r' zq) -> Test '(t,r,r',s,s',zp,zq) -prop_ctembed sk (PTCT x' x) = - let y = embedCT x :: CT s zp (Cyc t s' zq) - y' = decryptUnrestricted (embedSK sk) y - in test $ (embed x' :: Cyc t s zp) == y' - --- CT must be encrypted with key from small ring -prop_cttwace :: forall t r r' s s' z zp zq . - (Eq zp, - EncryptCtx t s s' z zp zq, - DecryptUCtx t r r' z zp zq, - r `Divides` s, - r' `Divides` s', - r ~ (FGCD r' s)) - => SK (Cyc t r' z) -> Cyc t s zp -> Test '(t,r,r',s,s',zp,zq) -prop_cttwace sk x = testIO $ do - y :: CT s zp (Cyc t s' zq) <- encrypt (embedSK sk) x - let y' = twaceCT y :: CT r zp (Cyc t r' zq) - x' = decryptUnrestricted sk y' - return $ (twace x :: Cyc t r zp) == x' - -prop_encDecU :: forall t m m' z zp zq . - (EncryptCtx t m m' z zp zq, - DecryptUCtx t m m' z zp zq, - Eq (Cyc t m zp)) - => SK (Cyc t m' z) -> Cyc t m zp -> Test '(t,m,m',zp,zq) -prop_encDecU sk x = testIO $ do - y :: CT m zp (Cyc t m' zq) <- encrypt sk x - let x' = decryptUnrestricted sk $ y - return $ x == x' - -prop_encDec :: forall t m m' z zp zq . - (EncryptCtx t m m' z zp zq, - DecryptCtx t m m' z zp zq, - Eq (Cyc t m zp)) +prop_encDec :: forall t m m' z zp zq . (z ~ LiftOf zp, _) => SK (Cyc t m' z) -> Cyc t m zp -> Test '(t,m,m',zp,zq) prop_encDec sk x = testIO $ do y :: CT m zp (Cyc t m' zq) <- encrypt sk x let x' = decrypt sk $ y return $ x == x' -helper :: (Proxy '(t,b) -> a) -> Proxy t -> Proxy b -> a -helper f _ _ = f Proxy - --- one-off tests, no hideArgsper -prop_modSwPT :: forall t m m' z zp zp' zq . - (Eq zp, Eq zp', - DecryptUCtx t m m' z zp zq, - DecryptUCtx t m m' z zp' zq, - ModSwitchPTCtx t m' zp zp' zq, - RescaleCyc (Cyc t) zp zp', - Mod zp, Mod zp', - ModRep zp ~ ModRep zp') - => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> Test '(t, '(m,m',zp',zp,zq)) -prop_modSwPT sk y = +prop_modSwPT :: forall t m m' z zp (zp' :: *) (zq :: *) . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zp',zq) +prop_modSwPT pt sk = testIO $ do + y :: CT m zp (Cyc t m' zq) <- encrypt sk pt let p = proxy modulus (Proxy::Proxy zp) p' = proxy modulus (Proxy::Proxy zp') z = (fromIntegral $ p `div` p')*y x = decryptUnrestricted sk z y' = modSwitchPT z :: CT m zp' (Cyc t m' zq) x'' = decryptUnrestricted sk y' - in test $ x'' == rescaleCyc Dec x + return $ x'' == rescaleCyc Dec x -modSwPTTests :: [IO TF.Test] -modSwPTTests = (modSwPTTests' (Proxy::Proxy CT.CT)) ++ (modSwPTTests' (Proxy::Proxy RT.RT)) - where modSwPTTests' p = - [helper (hideArgs prop_modSwPT) p (Proxy::Proxy '(F7,F21,Zq 4,Zq 8,Zq 18869761)), - helper (hideArgs prop_modSwPT) p (Proxy::Proxy '(F7,F42,Zq 2,Zq 4,Zq (18869761 ** 19393921)))] +prop_ksLin :: forall t m m' z zp (zq :: *) (zq' :: *) (gad :: *) . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) -> SK (Cyc t m' z) -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq,zq',gad) +prop_ksLin pt skin skout = testIO $ do + ct <- encrypt skin pt + kslHint :: KSLinearHint gad (Cyc t m' zq') <- ksLinearHint skout skin + let ct' = keySwitchLinear kslHint ct :: CT m zp (Cyc t m' zq) + pt' = decryptUnrestricted skout ct' + return $ pt == pt' -tunnelTests :: [IO TF.Test] -tunnelTests = (tunnelTests' (Proxy::Proxy CT.CT)) ++ (tunnelTests' (Proxy::Proxy RT.RT)) - where tunnelTests' p = - [helper (hideArgs prop_ringTunnel) p - (Proxy::Proxy '(F8,F40,F20,F60,Zq 4,Zq (18869761 ** 19393921),TrivGad))] +prop_ksQuad :: forall t m m' z zp zq (zq' :: *) (gad :: *) . (z ~ LiftOf zp, _) + => PT (Cyc t m zp) -> PT (Cyc t m zp) -> SK (Cyc t m' z) -> Test '(t,m,m',zp,zq,zq',gad) +prop_ksQuad pt1 pt2 sk = testIO $ do + ct1 :: CT m zp (Cyc t m' zq) <- encrypt sk pt1 + ct2 <- encrypt sk pt2 + ksqHint :: KSQuadCircHint gad (Cyc t m' zq') <- ksQuadCircHint sk + let ct' = keySwitchQuadCirc ksqHint $ ct1*ct2 + ptProd = pt1*pt2 + pt' = decryptUnrestricted sk ct' + return $ ptProd == pt' +prop_ctembed :: forall t r r' s s' z zp (zq :: *) . (z ~ LiftOf zp, Fact s', Fact s, _) + => PT (Cyc t r zp) -> SK (Cyc t r' z) -> Test '(t,r,r',s,s',zp,zq) +prop_ctembed pt sk =testIO $ do + ct :: CT r zp (Cyc t r' zq) <- encrypt sk pt + let ct' = embedCT ct :: CT s zp (Cyc t s' zq) + pt' = decryptUnrestricted (embedSK sk) ct' + return $ embed pt == pt' + +-- CT must be encrypted with key from small ring +prop_cttwace :: forall t r r' s s' z zp (zq :: *) . (z ~ LiftOf zp, Fact r, _) + => PT (Cyc t s zp) -> SK (Cyc t r' z) -> Test '(t,r,r',s,s',zp,zq) +prop_cttwace pt sk = testIO $ do + ct :: CT s zp (Cyc t s' zq) <- encrypt (embedSK sk) pt + let ct' = twaceCT ct :: CT r zp (Cyc t r' zq) + pt' = decryptUnrestricted sk ct' + return $ twace pt == pt' + prop_ringTunnel :: forall t e r s e' r' s' z zp zq gad . - (TunnelCtx t e r s e' r' s' z zp zq gad, + (GenTunnelInfoCtx t e r s e' r' s' z zp zq gad, + TunnelCtx t r s e' r' s' zp zq gad, EncryptCtx t r r' z zp zq, - GenSKCtx t r' z Double, - GenSKCtx t s' z Double, DecryptUCtx t s s' z zp zq, Random zp, Eq zp, e ~ FGCD r s, Fact e) - => Cyc t r zp -> Test '(t,'(r,r',s,s',zp,zq,gad)) -prop_ringTunnel x = testIO $ do + => PT (Cyc t r zp) -> SK (Cyc t r' z) -> SK (Cyc t s' z) -> Test '(t,r,r',s,s',zp,zq,gad) +prop_ringTunnel x skin skout = testIO $ do let totr = proxy totientFact (Proxy::Proxy r) tote = proxy totientFact (Proxy::Proxy e) basisSize = totr `div` tote -- choose a random linear function of the appropriate size bs :: [Cyc t s zp] <- replicateM basisSize getRandom - let f = (linearDec bs) \\ (gcdDivides (Proxy::Proxy r) (Proxy::Proxy s)) :: Linear t zp e r s + let f = linearDec bs \\ (gcdDivides (Proxy::Proxy r) (Proxy::Proxy s)) :: Linear t zp e r s expected = evalLin f x \\ (gcdDivides (Proxy::Proxy r) (Proxy::Proxy s)) - skin :: SK (Cyc t r' (LiftOf zp)) <- genSK v - skout :: SK (Cyc t s' (LiftOf zp)) <- genSK v y :: CT r zp (Cyc t r' zq) <- encrypt skin x - tunn <- proxyT (tunnelCT f skout skin) (Proxy::Proxy gad) - let y' = tunn y :: CT s zp (Cyc t s' zq) + hints :: TunnelInfo gad t e r s e' r' s' zp zq <- tunnelInfo f skout skin + let y' = tunnelCT hints y :: CT s zp (Cyc t s' zq) actual = decryptUnrestricted skout y' :: Cyc t s zp return $ expected == actual - diff --git a/tests/TestAppsMain.hs b/tests/TestAppsMain.hs new file mode 100644 --- /dev/null +++ b/tests/TestAppsMain.hs @@ -0,0 +1,115 @@ +{-| +Module : TestAppsMain +Description : Main driver for lol-apps tests. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Main driver for lol-apps tests. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module TestAppsMain where + +import Control.Monad.Random + +import Crypto.Lol (Cyc) +import Crypto.Lol.Applications.SymmSHE hiding (CT) +import Crypto.Lol.Cyclotomic.Tensor.CPP +import Crypto.Lol.Cyclotomic.Tensor.Repa +import Crypto.Lol.Factored +import Crypto.Lol.Gadget +import Crypto.Lol.Types + +import Data.Int +import Data.Proxy + +import KHPRFTests +import SHETests +import Test.Framework + +infixr 9 ** +data a ** b + +type family Zq (a :: k) :: * where + Zq (a ** b) = (Zq a, Zq b) + Zq q = (ZqBasic q Int64) + +main :: IO () +main = do + flip defaultMainWithArgs ["--threads=1","--maximum-generated-tests=100"] $ concat + [defaultTests (Proxy::Proxy CT) (Proxy::Proxy TrivGad), + defaultTests (Proxy::Proxy RT) (Proxy::Proxy TrivGad)] + +defaultTests :: _ => Proxy t -> Proxy gad -> [Test] +defaultTests pt pgad = + [testGroup "SHE" $ ($ pt) <$> [ + sheTests (Proxy::Proxy '(F7, F7, Zq 2,Zq (19393921 ** 18869761))), + sheTests (Proxy::Proxy '(F7, F21,Zq 2,Zq (19393921 ** 18869761))), + sheTests (Proxy::Proxy '(F2, F8, Zq 2,Zq 536871001)), + sheTests (Proxy::Proxy '(F1, F8, Zq 2,Zq 536871001)), + sheTests (Proxy::Proxy '(F4, F12,Zq 2,Zq 2148249601)), + sheTests (Proxy::Proxy '(F4, F8, Zq 3,Zq 2148249601)), + sheTests (Proxy::Proxy '(F7, F7, Zq 4,Zq (19393921 ** 18869761))), + sheTests (Proxy::Proxy '(F7, F21,Zq 4,Zq (19393921 ** 18869761))), + sheTests (Proxy::Proxy '(F1, F4, Zq 4,Zq 18869761)), + sheTests (Proxy::Proxy '(F4, F4, Zq 4,Zq 18869761)), + sheTests (Proxy::Proxy '(F14,F14,Zq 4,Zq 18869761)), + sheTests (Proxy::Proxy '(F28,F28,Zq 4,Zq 18869761)), + sheTests (Proxy::Proxy '(F28,F28,Zq 4,Zq 80221)), + sheTests (Proxy::Proxy '(F1, F8, Zq 4,Zq 536871001)), + sheTests (Proxy::Proxy '(F2, F8, Zq 4,Zq 536871001)), + sheTests (Proxy::Proxy '(F4, F12,Zq 8,Zq 2148249601)), + + decTest (Proxy::Proxy '(F2, F8, Zq 2,Zq 536871001)), + decTest (Proxy::Proxy '(F1, F8, Zq 2,Zq 536871001)), + decTest (Proxy::Proxy '(F4, F12,Zq 2,Zq 2148249601)), + decTest (Proxy::Proxy '(F4, F8, Zq 3,Zq 2148249601)), + decTest (Proxy::Proxy '(F1, F4, Zq 4,Zq 18869761)), + decTest (Proxy::Proxy '(F4, F4, Zq 4,Zq 18869761)), + decTest (Proxy::Proxy '(F14,F14,Zq 4,Zq 18869761)), + decTest (Proxy::Proxy '(F28,F28,Zq 4,Zq 18869761)), + decTest (Proxy::Proxy '(F28,F28,Zq 4,Zq 80221)), + decTest (Proxy::Proxy '(F1, F8, Zq 4,Zq 536871001)), + decTest (Proxy::Proxy '(F2, F8, Zq 4,Zq 536871001)), + decTest (Proxy::Proxy '(F4, F12,Zq 8,Zq 2148249601)), + + modSwPTTest (Proxy::Proxy '(F7,F21,Zq 4,Zq 8,Zq 18869761)), + modSwPTTest (Proxy::Proxy '(F7,F42,Zq 2,Zq 4,Zq (18869761 ** 19393921))), + + ksTests (Proxy::Proxy '(F1, F7, Zq 2, Zq 19393921, Zq (19393921 ** 18869761))) pgad, + ksTests (Proxy::Proxy '(F2, F4, Zq 8, Zq 2148854401, Zq (2148854401 ** 2148249601))) pgad, + ksTests (Proxy::Proxy '(F4, F12, Zq 2, Zq 2148854401, Zq (2148854401 ** 2148249601))) pgad, + ksTests (Proxy::Proxy '(F8, F64, Zq 2, Zq 2148854401, Zq (2148854401 ** 2148249601))) pgad, + ksTests (Proxy::Proxy '(F3, F27, Zq 2, Zq 2148854401, Zq (2148854401 ** 2148249601))) pgad, + ksTests (Proxy::Proxy '(F2, F4, Zq 8, Zq 2148854401, Zq (2148854401 ** 2148249601 ** 2150668801))) pgad, + ksTests (Proxy::Proxy '(F4, F12, Zq 2, Zq 2148854401, Zq (2148854401 ** 2148249601 ** 2150668801))) pgad, + ksTests (Proxy::Proxy '(F8, F64, Zq 2, Zq 2148854401, Zq (2148854401 ** 2148249601 ** 2150668801))) pgad, + ksTests (Proxy::Proxy '(F3, F27, Zq 2, Zq 2148854401, Zq (2148854401 ** 2148249601 ** 2150668801))) pgad, + + twemTests (Proxy::Proxy '(F1, F7, F3, F21, Zq 2, Zq 18869761)), + + tunnelTests (Proxy::Proxy '(F8,F40,F20,F60,Zq 4,Zq (18869761 ** 19393921))) pgad], + testGroup "KHPRF" $ ($ pt) <$> [ + khprfTests (Proxy::Proxy '(F32, Zq 2, Zq 8, BaseBGad 2)), + khprfTests (Proxy::Proxy '(F32, Zq 2, Zq 8, TrivGad)), + khprfTests (Proxy::Proxy '(F32, Zq 32, Zq 257, BaseBGad 2))] + ] + +-- EAC: is there a simple way to parameterize the variance? +-- generates a secret key with scaled variance 1.0 +instance (GenSKCtx t m' z Double) => Random (SK (Cyc t m' z)) where + random = runRand $ genSK (1 :: Double) + randomR = error "randomR not defined for SK" diff --git a/utils/Apply.hs b/utils/Apply.hs deleted file mode 100644 --- a/utils/Apply.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, PolyKinds, - TypeFamilies, TypeOperators #-} - --- applies functions to proxy arguments -module Apply where - --- not associated due to the generic instance below: --- any definition of ArgsCtx would conflict with specific instances -data family ArgsCtx ctx - -class (params :: [k]) `Satisfy` (ctx :: *) where - run :: proxy params - -> (ArgsCtx ctx -> rnd res) - -> [rnd res] - -instance '[] `Satisfy` ctx where - run _ _ = [] diff --git a/utils/Apply/SHE.hs b/utils/Apply/SHE.hs deleted file mode 100644 --- a/utils/Apply/SHE.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Apply.SHE -(AddZq -,Liftable -,NonLiftable -,RoundDown -,applyKSQ -,applyRescale -,applyDec -,applyCTFunc -,applyEnc -,applyTunn -,applyCTTwEm -) where - -import Apply -import GenArgs -import Utils - -import Control.DeepSeq -import Control.Monad.Random -import Control.Monad.State - -import Crypto.Lol -import Crypto.Lol.Applications.SymmSHE -import Crypto.Lol.Types.ZPP - -import Crypto.Random.DRBG - -import Data.Promotion.Prelude.Eq -import Data.Singletons -import Data.Singletons.TypeRepStar () - -data AddZq :: TyFun (Factored, Factored, *, *) (Factored, Factored, *, *, *) -> * -type instance Apply AddZq '(m,m',zp,zq) = '(m,m',zp,RoundDown zq,zq) - -data Liftable :: TyFun (Factored, Factored, *, *) Bool -> * -type instance Apply Liftable '(m,m',zp,zq) = Int64 :== (LiftOf zq) - -data NonLiftable :: TyFun (Factored, Factored, *, *) Bool -> * -type instance Apply NonLiftable '(m,m',zp,zq) = Integer :== (LiftOf zq) - -type family RoundDown zq where - RoundDown (a,(b,c)) = (b,c) - RoundDown ((a,b),c) = (a,b) - RoundDown (a,b) = a - -data DecCtxD -type DecCtx t m m' zp zq = - (Random zp, NFElt zp, - EncryptCtx t m m' (LiftOf zp) zp zq, - -- ^ these provide the context to generate the parameters - DecryptCtx t m m' (LiftOf zp) zp zq, Eq zp, - ShowType '(t,m,m',zp,zq)) -data instance ArgsCtx DecCtxD where - DecD :: (DecCtx t m m' zp zq) => Proxy '(t,m,m',zp,zq) -> ArgsCtx DecCtxD -instance (params `Satisfy` DecCtxD, DecCtx t m m' zp zq) - => ( '(t, '(m,m',zp,zq)) ': params) `Satisfy` DecCtxD where - run _ f = f (DecD (Proxy::Proxy '(t,m,m',zp,zq))) : run (Proxy::Proxy params) f - -applyDec :: (params `Satisfy` DecCtxD) => - Proxy params -> - (forall t m m' zp zq . (DecCtx t m m' zp zq) - => Proxy '(t,m,m',zp,zq) -> rnd res) - -> [rnd res] -applyDec params g = run params $ \(DecD p) -> g p - -data TunnCtxD --- union of compatible constraints in benchmarks -type TunnCtx t r r' e e' s s' zp zq gad = - (NFData (CT s zp (Cyc t s' zq)), - ShowType '(t,r,r',s,s',zp,zq,gad), - EncryptCtx t r r' (LiftOf zp) zp zq, - EncryptCtx t s s' (LiftOf zp) zp zq, - TunnelCtx t e r s e' r' s' (LiftOf zp) zp zq gad, - e ~ FGCD r s, - ZPP zp, Random zp, - Fact e, - CElt t (ZpOf zp)) -data instance ArgsCtx TunnCtxD where - TunnD :: (TunnCtx t r r' e e' s s' zp zq gad) - => Proxy '(t,r,r',s,s',zp,zq,gad) -> ArgsCtx TunnCtxD -instance (params `Satisfy` TunnCtxD, TunnCtx t r r' e e' s s' zp zq gad) - => ( '(gad, '(t, '( '(r,r',s,s'), '(zp,zq)))) ': params) `Satisfy` TunnCtxD where - run _ f = f (TunnD (Proxy::Proxy '(t,r,r',s,s',zp,zq,gad))) : run (Proxy::Proxy params) f - -applyTunn :: (params `Satisfy` TunnCtxD) => - Proxy params -> - (forall t r r' e e' s s' zp zq gad . (TunnCtx t r r' e e' s s' zp zq gad) - => Proxy '(t,r,r',s,s',zp,zq,gad) -> rnd res) - -> [rnd res] -applyTunn params g = run params $ \(TunnD p) -> g p - -data CTEmCtxD --- union of compatible constraints in benchmarks -type CTEmCtx t r r' s s' zp zq = - (Random zp, Eq zp, -- CJP: added b/c CElt doesn't have them - DecryptUCtx t r r' (LiftOf zp) zp zq, - DecryptUCtx t s s' (LiftOf zp) zp zq, - ShowType '(t,r,r',s,s',zp,zq), - EncryptCtx t r r' (LiftOf zp) zp zq, - r `Divides` s, - r' `Divides` s', - s `Divides` s', - r ~ (FGCD r' s)) -data instance ArgsCtx CTEmCtxD where - TwEmD :: (CTEmCtx t r r' s s' zp zq) - => Proxy '(t,r,r',s,s',zp,zq) -> ArgsCtx CTEmCtxD -instance (params `Satisfy` CTEmCtxD, CTEmCtx t r r' s s' zp zq) - => ( '(t, '(r,r',s,s',zp,zq)) ': params) `Satisfy` CTEmCtxD where - run _ f = f (TwEmD (Proxy::Proxy '(t,r,r',s,s',zp,zq))) : run (Proxy::Proxy params) f - -applyCTTwEm :: (params `Satisfy` CTEmCtxD) => - Proxy params -> - (forall t r r' s s' zp zq . (CTEmCtx t r r' s s' zp zq) - => Proxy '(t,r,r',s,s',zp,zq) -> rnd res) - -> [rnd res] -applyCTTwEm params g = run params $ \(TwEmD p) -> g p - --- allowed args: CT, KSHint, SK --- context for (*), (==), decryptUnrestricted -data KSQCtxD --- it'd be nice to make this associated to `Satsify`, --- but we have to use a *ton* of kind signatures if we do -type KSQCtx gad t m m' zp zq zq' = - (Random zp, Eq zp, -- CJP: added b/c CElt doesn't have them - EncryptCtx t m m' (LiftOf zp) zp zq, - DecryptUCtx t m m' (LiftOf zp) zp zq, - KeySwitchCtx gad t m' zp zq zq', - KSHintCtx gad t m' (LiftOf zp) zq', - -- ^ these provide the context to generate the parameters - Ring (CT m zp (Cyc t m' zq)), - -- Eq (Cyc t m zp), - Fact m, Fact m', CElt t zp, m `Divides` m', - Reduce (LiftOf zp) zq, Lift' zq, CElt t (LiftOf zp), ToSDCtx t m' zp zq, Reduce (LiftOf zq) zp, - -- ^ these provide the context for tests - NFData (CT m zp (Cyc t m' zq)), - ShowType '(t,m,m',zp,zq,zq',gad)) - -- ^ these provide the context for benchmarks -data instance ArgsCtx KSQCtxD where - KSQD :: (KSQCtx gad t m m' zp zq zq') - => Proxy '(t,m,m',zp,zq,zq',gad) -> ArgsCtx KSQCtxD -instance (params `Satisfy` KSQCtxD, KSQCtx gad t m m' zp zq zq') - => ( '(gad , '(t, '(m, m', zp, zq, zq'))) ': params) `Satisfy` KSQCtxD where - run _ f = f (KSQD (Proxy::Proxy '(t,m,m',zp,zq,zq',gad))) : run (Proxy::Proxy params) f - -applyKSQ :: (params `Satisfy` KSQCtxD) => - Proxy params -> - (forall t m m' zp zq zq' gad . (KSQCtx gad t m m' zp zq zq') - => Proxy '(t,m,m',zp,zq,zq',gad) -> rnd res) - -> [rnd res] -applyKSQ params g = run params $ \(KSQD p) -> g p - -data RescaleCtxD -type RescaleCtx t m m' zp zq zq' = - (Random zp, - EncryptCtx t m m' (LiftOf zp) zp zq', - ShowType '(t,m,m',zp,zq,zq'), - RescaleCyc (Cyc t) zq' zq, - NFData (CT m zp (Cyc t m' zq)), - ToSDCtx t m' zp zq') -data instance ArgsCtx RescaleCtxD where - RD :: (RescaleCtx t m m' zp zq zq') - => Proxy '(t,m,m',zp,zq,zq') -> ArgsCtx RescaleCtxD -instance (params `Satisfy` RescaleCtxD, RescaleCtx t m m' zp zq zq') - => ( '(t, '(m,m',zp,zq,zq')) ': params) `Satisfy` RescaleCtxD where - run _ f = f (RD (Proxy::Proxy '(t,m,m',zp,zq,zq'))) : run (Proxy::Proxy params) f - -applyRescale :: (params `Satisfy` RescaleCtxD) => - Proxy params -> - (forall t m m' zp zq zq' . (RescaleCtx t m m' zp zq zq') - => Proxy '(t,m,m',zp,zq,zq') -> rnd res) - -> [rnd res] -applyRescale params g = run params $ \(RD p) -> g p - -data CTCtxD --- union of compatible constraints in benchmarks -type CTCtx t m m' zp zq = - (Random zp, Eq zp, NFElt zp, NFElt zq, -- CJP: CElt doesn't have these - EncryptCtx t m m' (LiftOf zp) zp zq, - Ring (CT m zp (Cyc t m' zq)), - AddPublicCtx t m m' zp zq, - DecryptUCtx t m m' (LiftOf zp) zp zq, - MulPublicCtx t m m' zp zq, - ShowType '(t,m,m',zp,zq)) -data instance ArgsCtx CTCtxD where - CTD :: (CTCtx t m m' zp zq) - => Proxy '(t,m,m',zp,zq) -> ArgsCtx CTCtxD -instance (params `Satisfy` CTCtxD, CTCtx t m m' zp zq) - => ( '(t, '(m,m',zp,zq)) ': params) `Satisfy` CTCtxD where - run _ f = f (CTD (Proxy::Proxy '(t,m,m',zp,zq))) : run (Proxy::Proxy params) f - -applyCTFunc :: (params `Satisfy` CTCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m m' zp zq . (CTCtx t m m' zp zq, Generatable (StateT (Maybe (SK (Cyc t m' (LiftOf zp)))) rnd) zp) - => Proxy '(t,m,m',zp,zq) -> rnd res) - -> [rnd res] -applyCTFunc params g = run params $ \(CTD p) -> g p - -data EncCtxD -type EncCtx t m m' zp zq gen = - (Random zp, NFElt zp, NFElt zq, - EncryptCtx t m m' (LiftOf zp) zp zq, - Ring (CT m zp (Cyc t m' zq)), - AddPublicCtx t m m' zp zq, - MulPublicCtx t m m' zp zq, - ShowType '(t,m,m',zp,zq,gen), - CryptoRandomGen gen) -data instance ArgsCtx EncCtxD where - EncD :: (EncCtx t m m' zp zq gen) - => Proxy '(t,m,m',zp,zq,gen) -> ArgsCtx EncCtxD -instance (params `Satisfy` EncCtxD, EncCtx t m m' zp zq gen) - => ( '(gen, '(t, '(m,m',zp,zq))) ': params) `Satisfy` EncCtxD where - run _ f = f (EncD (Proxy::Proxy '(t,m,m',zp,zq,gen))) : run (Proxy::Proxy params) f - -applyEnc :: (params `Satisfy` EncCtxD) => - Proxy params - -> (forall t m m' zp zq gen . (EncCtx t m m' zp zq gen) - => Proxy '(t,m,m',zp,zq,gen) -> rnd res) - -> [rnd res] -applyEnc params g = run params $ \(EncD p) -> g p diff --git a/utils/Benchmarks.hs b/utils/Benchmarks.hs deleted file mode 100644 --- a/utils/Benchmarks.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} - -module Benchmarks -(Benchmarks.bench -,benchIO -,benchGroup -,hideArgs -,Bench(..) -,Benchmark -,NFData) where - -import GenArgs -import Utils - -import Control.DeepSeq -import Criterion as C - -import Data.Proxy - --- wrapper for Criterion's `nf` -bench :: NFData b => (a -> b) -> a -> Bench params -bench f = Bench . nf f - --- wrapper for Criterion's `nfIO` -benchIO :: NFData b => IO b -> Bench params -benchIO = Bench . nfIO - --- wrapper for Criterion's -benchGroup :: (Monad rnd) => String -> [rnd Benchmark] -> rnd Benchmark -benchGroup str = (bgroup str <$>) . sequence - --- normalizes any function resulting in a Benchmark to --- one that takes a proxy for its arguments -hideArgs :: (GenArgs rnd bnch, Monad rnd, ShowType a, - ResultOf bnch ~ Bench a) - => bnch -> Proxy a -> rnd Benchmark -hideArgs f p = (C.bench (showType p) . unbench) <$> genArgs f - -newtype Bench params = Bench {unbench :: Benchmarkable} - -instance (Monad rnd) => GenArgs rnd (Bench params) where - type ResultOf (Bench params) = Bench params - genArgs = return diff --git a/utils/GenArgs.hs b/utils/GenArgs.hs deleted file mode 100644 --- a/utils/GenArgs.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} - --- generates arguments to functions -module GenArgs where - -import Control.Monad.Random -import Data.Proxy - --- bnch represents a function whose arguments can be generated, --- resulting in a "NFValue" -class GenArgs rnd bnch where - type ResultOf bnch - genArgs :: bnch -> rnd (ResultOf bnch) - -instance (Generatable rnd a, GenArgs rnd b, - Monad rnd, ResultOf b ~ ResultOf (a -> b)) - => GenArgs rnd (a -> b) where - type ResultOf (a -> b) = ResultOf b - genArgs f = do - x <- genArg - genArgs $ f x - --- a parameter that can be generated using a particular monad -class Generatable rnd arg where - genArg :: rnd arg - -instance {-# Overlappable #-} (Random a, MonadRandom rnd) => Generatable rnd a where - genArg = getRandom - -instance (Monad rnd) => Generatable rnd (Proxy a) where - genArg = return Proxy diff --git a/utils/GenArgs/SHE.hs b/utils/GenArgs/SHE.hs deleted file mode 100644 --- a/utils/GenArgs/SHE.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, - MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, - UndecidableInstances #-} - -module GenArgs.SHE where - -import GenArgs - -import Control.Applicative -import Control.Monad.Random -import Control.Monad.State - -import Crypto.Lol -import Crypto.Lol.Applications.SymmSHE -import Crypto.Lol.Types.ZPP - ---extract an SK type from a tuple of params -type family SKOf (a :: k) :: * where - SKOf '(t,m,m',zp,zq) = SK (Cyc t m' (LiftOf zp)) - SKOf '(t,m,m',zp,zq,zq') = SK (Cyc t m' (LiftOf zp)) - SKOf '(t,m,m',zp,zq,zq',gad) = SK (Cyc t m' (LiftOf zp)) - SKOf '(t,r,r',s,s',zp,zq) = SK (Cyc t r' (LiftOf zp)) - SKOf '(t,r,r',s,s',zp,zq,gad) = SK (Cyc t r' (LiftOf zp)) - SKOf '(t,'(m,m',zp,zp',zq)) = SK (Cyc t m' (LiftOf zp)) - --- generates a secrete key with svar=1, using non-cryptographic randomness -instance (GenSKCtx t m z Double, - MonadRandom rnd, - MonadState (Maybe (SK (Cyc t m z))) rnd) - => Generatable rnd (SK (Cyc t m z)) where - genArg = do - msk <- get - case msk of - Just sk -> return sk - Nothing -> do - sk <- genSK (1 :: Double) - put $ Just sk - return sk - -instance (Generatable rnd (PTCT m zp (Cyc t m' zq)), Monad rnd) - => Generatable rnd (CT m zp (Cyc t m' zq)) where - genArg = do - (PTCT _ ct) :: PTCT m zp (Cyc t m' zq) <- genArg - return ct - --- use this data type in functions that need a circular key switch hint -newtype KSHint m zp t m' zq gad zq' = KeySwitch (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) -instance (Generatable rnd (SK (Cyc t m' z)), - z ~ LiftOf zp, - KeySwitchCtx gad t m' zp zq zq', - KSHintCtx gad t m' z zq', - MonadRandom rnd) - => Generatable rnd (KSHint m zp t m' zq gad zq') where - genArg = do - sk :: SK (Cyc t m' z) <- genArg - KeySwitch <$> proxyT (keySwitchQuadCirc sk) (Proxy::Proxy (gad,zq')) - -newtype Tunnel t r r' s s' zp zq gad = Tunnel (CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq)) -instance (Generatable rnd (SK (Cyc t r' z)), - z ~ LiftOf zp, - TunnelCtx t e r s e' r' s' z zp zq gad, - e ~ FGCD r s, - ZPP zp, - Fact e, - CElt t (ZpOf zp), - MonadRandom rnd, - Generatable (StateT (Maybe (SK (Cyc t s' z))) rnd) (SK (Cyc t s' z))) - => Generatable rnd (Tunnel t r r' s s' zp zq gad) where - genArg = do - skin :: SK (Cyc t r' z) <- genArg - -- EAC: bit of a hack for now - skout <- evalStateT genArg (Nothing :: Maybe (SK (Cyc t s' z))) - let crts :: [Cyc t s zp] = proxy crtSet (Proxy::Proxy e)\\ gcdDivides (Proxy::Proxy r) (Proxy::Proxy s) - r = proxy totientFact (Proxy::Proxy r) - e = proxy totientFact (Proxy::Proxy e) - dim = r `div` e - -- only take as many crts as we need - -- otherwise linearDec fails - linf :: Linear t zp e r s = linearDec (take dim crts) \\ gcdDivides (Proxy::Proxy r) (Proxy::Proxy s) - Tunnel <$> proxyT (tunnelCT linf skout skin) (Proxy::Proxy gad) - -data KSLinear t m m' z zp zq (zq' :: *) (gad :: *) = KSL (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) (SK (Cyc t m' z)) -instance (KeySwitchCtx gad t m' zp zq zq', - KSHintCtx gad t m' z zq', - MonadRandom rnd, - Generatable rnd (SK (Cyc t m' z)), -- for skin - Generatable (StateT (Maybe (SK (Cyc t m' z))) rnd) (SK (Cyc t m' z))) -- for skout - => Generatable rnd (KSLinear t m m' z zp zq zq' gad) where - genArg = do - skin <- genArg - -- generate an independent key - skout <- evalStateT genArg (Nothing :: Maybe (SK (Cyc t m' z))) - ksl <- proxyT (keySwitchLinear skout skin) (Proxy::Proxy (gad,zq')) - return $ KSL ksl skout - -data PTCT m zp rq where - PTCT :: Cyc t m zp -> CT m zp (Cyc t m' zq) -> PTCT m zp (Cyc t m' zq) -instance (EncryptCtx t m m' z zp zq, - z ~ LiftOf zp, - MonadRandom rnd, - Generatable rnd (SK (Cyc t m' z)), - Generatable rnd (Cyc t m zp), - rq ~ Cyc t m' zq) - => Generatable rnd (PTCT m zp rq) where - genArg = do - sk :: SK (Cyc t m' z) <- genArg - pt <- genArg - ct <- encrypt sk pt - return $ PTCT pt ct diff --git a/utils/TestTypes.hs b/utils/TestTypes.hs deleted file mode 100644 --- a/utils/TestTypes.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, TypeOperators #-} - -module TestTypes -(SmoothQ1, SmoothQ2, SmoothQ3 -,SmoothZQ1, SmoothZQ2, SmoothZQ3 -,Zq -,ZQ1,ZQ2,ZQ3) where - -import Control.Monad.Random - -import Crypto.Lol - -import Utils - -import Test.QuickCheck.Monadic - -instance (MonadRandom m) => MonadRandom (PropertyM m) where - getRandom = run getRandom - getRandoms = run getRandoms - getRandomR r = run $ getRandomR r - getRandomRs r = run $ getRandomRs r - --- three 24-bit moduli, enough to handle rounding for p=32 (depth-4 circuit at ~17 bits per mul) -type ZQ1 = Zq 18869761 -type ZQ2 = Zq (19393921 ** 18869761) -type ZQ3 = Zq (19918081 ** 19393921 ** 18869761) - --- the next three moduli are "good" for any index dividing 128*27*25*7 -type SmoothQ1 = 2148249601 -type SmoothQ2 = 2148854401 -type SmoothQ3 = 2150668801 - -type SmoothZQ1 = Zq 2148249601 -type SmoothZQ2 = Zq (2148854401 ** 2148249601) -type SmoothZQ3 = Zq (2148854401 ** 2148249601 ** 2150668801) diff --git a/utils/Tests.hs b/utils/Tests.hs deleted file mode 100644 --- a/utils/Tests.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, - PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} -module Tests -(test -,testIO -,TF.testGroup -,testGroupM -,hideArgs -,Test(..)) where - -import GenArgs -import Utils - -import Control.Monad.Random - -import Data.Proxy - -import qualified Test.Framework as TF -import Test.Framework.Providers.QuickCheck2 - -test :: Bool -> Test params -test = Test - -testIO :: (forall m . MonadRandom m => m Bool) -> Test params -testIO = TestM - -testGroupM :: String -> [IO TF.Test] -> TF.Test -testGroupM str = TF.buildTest . (TF.testGroup str <$>) . sequence - --- normalizes any function resulting in a Benchmark to --- one that takes a proxy for its arguments -hideArgs :: (GenArgs rnd bnch, MonadRandom rnd, ShowType a, - ResultOf bnch ~ Test a) - => bnch -> Proxy a -> rnd TF.Test -hideArgs f p = do - res <- genArgs f - case res of - Test b -> return $ testProperty (showType p) b - TestM b -> testProperty (showType p) <$> b - -data Test params where - Test :: Bool -> Test params - TestM :: (forall m . MonadRandom m => m Bool) -> Test params - -instance (MonadRandom rnd) => GenArgs rnd (Test params) where - type ResultOf (Test params) = Test params - genArgs = return diff --git a/utils/Utils.hs b/utils/Utils.hs deleted file mode 100644 --- a/utils/Utils.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, - GADTs, KindSignatures, MultiParamTypeClasses, PolyKinds, - RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module Utils -(Zq -,type (**) -,type (<$>) -,type (<*>) - -,module Data.Promotion.Prelude.List -,goodQs -,showType -,ShowType) where - -import Crypto.Lol (Int64,Fact,valueFact,Mod(..), Proxy(..), proxy, TrivGad, BaseBGad) -import Crypto.Lol.Reflects -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor -import Crypto.Lol.Cyclotomic.Tensor.CTensor -import Crypto.Lol.Types.ZqBasic -import Crypto.Random.DRBG - -import Data.Promotion.Prelude.List - -import Math.NumberTheory.Primes.Testing (isPrime) - --- an infinite list of primes greater than the input and congruent to --- 1 mod m -goodQs :: (Integral i) => i -> i -> [i] -goodQs m lower = checkVal (lower + ((m-lower) `mod` m) + 1) - where checkVal v = if (isPrime (fromIntegral v :: Integer)) - then v : checkVal (v+m) - else checkVal (v+m) - -infixr 9 ** -data a ** b - -type family Zq (a :: k) :: * where - Zq (a ** b) = (Zq a, Zq b) - Zq q = (ZqBasic q Int64) - - -type family (f :: (k1 -> k2)) <$> (xs :: [k1]) where - f <$> '[] = '[] - f <$> (x ': xs) = (f x) ': (f <$> xs) - -type family (fs :: [k1 -> k2]) <*> (xs :: [k1]) where - fs <*> xs = Go fs xs xs - -type family Go (fs :: [k1 -> k2]) (xs :: [k1]) (ys :: [k1]) where - Go '[] xs ys = '[] - Go (f ': fs) '[] ys = Go fs ys ys - Go (f ': fs) (x ': xs) ys = (f x) ': (Go (f ': fs) xs ys) - - - - - - - --- a wrapper type for printing test/benchmark names -data ArgType (a :: k) = AT - --- allows automatic printing of test parameters -type ShowType a = Show (ArgType a) - -showType :: forall a . (Show (ArgType a)) => Proxy a -> String -showType _ = show (AT :: ArgType a) - -instance Show (ArgType HashDRBG) where - show _ = "HashDRBG" - -instance (Fact m) => Show (ArgType m) where - show _ = "F" ++ show (proxy valueFact (Proxy::Proxy m)) - -instance (Mod (ZqBasic q i), Show i) => Show (ArgType (ZqBasic q i)) where - show _ = "Q" ++ show (proxy modulus (Proxy::Proxy (ZqBasic q i))) - -instance Show (ArgType RT) where - show _ = "RT" - -instance Show (ArgType CT) where - show _ = "CT" - -instance Show (ArgType Int64) where - show _ = "Int64" - -instance Show (ArgType TrivGad) where - show _ = "TrivGad" - -instance (Reflects b Integer) => Show (ArgType (BaseBGad (b :: k))) where - show _ = "Base" ++ show (proxy value (Proxy::Proxy b) :: Integer) ++ "Gad" - --- for RNS-style moduli -instance (Show (ArgType a), Show (ArgType b)) => Show (ArgType (a,b)) where - show _ = show (AT :: ArgType a) ++ "*" ++ show (AT :: ArgType b) - --- we use tuples rather than lists because types in a list must have the same kind, --- but tuples permit different kinds -instance (Show (ArgType a), Show (ArgType b)) - => Show (ArgType '(a,b)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType b) - -instance (Show (ArgType a), Show (ArgType '(b,c))) - => Show (ArgType '(a,b,c)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c)) - -instance (Show (ArgType a), Show (ArgType '(b,c,d))) - => Show (ArgType '(a,b,c,d)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d)) - -instance (Show (ArgType a), Show (ArgType '(b,c,d,e))) - => Show (ArgType '(a,b,c,d,e)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e)) - -instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f))) - => Show (ArgType '(a,b,c,d,e,f)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e,f)) - -instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f,g))) - => Show (ArgType '(a,b,c,d,e,f,g)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e,f,g)) - -instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f,g,h))) - => Show (ArgType '(a,b,c,d,e,f,g,h)) where - show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e,f,g,h))