packages feed

lol-apps 0.1.1.0 → 0.2.0.0

raw patch · 38 files changed

+2955/−1229 lines, 38 filesdep +containersdep +filepathdep +lol-benchesdep ~MonadRandomdep ~QuickCheckdep ~basenew-component:exe:homomprfnew-component:exe:khprfnew-component:exe:symmshe

Dependencies added: containers, filepath, lol-benches, lol-cpp, lol-repa, lol-tests, protocol-buffers, protocol-buffers-descriptor, split, time

Dependency ranges changed: MonadRandom, QuickCheck, base, deepseq, lol, numeric-prelude, test-framework, test-framework-quickcheck2

Files

CHANGES.md view
@@ -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 -----
+ Crypto/Lol/Applications/HomomPRF.hs view
@@ -0,0 +1,530 @@+{-|+Module      : Crypto.Lol.Applications.HomomPRF+Description : Homomorphic evaluation of the PRF from <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]>.+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 <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]>.+-}++{-# 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+-- <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]> 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
+ Crypto/Lol/Applications/KeyHomomorphicPRF.hs view
@@ -0,0 +1,243 @@+{-|+Module      : Crypto.Lol.Applications.KeyHomomorphicPRF+Description : Key-homomorphic PRF from <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]>.+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 <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]>.+-}++{-# 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 <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]>.+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 <http://web.eecs.umich.edu/~cpeikert/pubs/kh-prf.pdf [BP14]>.+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
Crypto/Lol/Applications/SymmSHE.hs view
@@ -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+<http://eprint.iacr.org/2015/1134> 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
+ Crypto/Proto/HomomPRF.hs view
@@ -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")
+ Crypto/Proto/HomomPRF/LinearFuncChain.hs view
@@ -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}))
+ Crypto/Proto/HomomPRF/RoundHintChain.hs view
@@ -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}))
+ Crypto/Proto/HomomPRF/TunnelInfoChain.hs view
@@ -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}))
+ Crypto/Proto/SHE.hs view
@@ -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")
+ Crypto/Proto/SHE/KSHint.hs view
@@ -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}))
+ Crypto/Proto/SHE/RqPolynomial.hs view
@@ -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}))
+ Crypto/Proto/SHE/SecretKey.hs view
@@ -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}))
+ Crypto/Proto/SHE/TunnelInfo.hs view
@@ -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}))
+ HomomPRF.proto view
@@ -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;+}
README view
@@ -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.
+ SHE.proto view
@@ -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+}
+ benchmarks/BenchAppsMain.hs view
@@ -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"
+ benchmarks/KHPRFBenches.hs view
@@ -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
− benchmarks/Main.hs 
@@ -1,9 +0,0 @@--import SHEBenches--import Criterion.Main--main :: IO ()-main = defaultMain =<< sequence [-  sheBenches-  ]
benchmarks/SHEBenches.hs view
@@ -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
+ examples/HomomPRFMain.hs view
@@ -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
+ examples/HomomPRFParams.hs view
@@ -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
+ examples/KHPRFMain.hs view
@@ -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
+ examples/SHEMain.hs view
@@ -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))+
− examples/SymmSHE/SimpleSHE.hs 
@@ -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))-
lol-apps.cabal view
@@ -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-    <https://hackage.haskell.org/package/lol Λ ○ λ>  (Lol),+    <https://hackage.haskell.org/package/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
+ tests/KHPRFTests.hs view
@@ -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
− tests/Main.hs 
@@ -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-    ]
tests/SHETests.hs view
@@ -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-
+ tests/TestAppsMain.hs view
@@ -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"
− utils/Apply.hs 
@@ -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 _ _ = []
− utils/Apply/SHE.hs 
@@ -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
− utils/Benchmarks.hs 
@@ -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
− utils/GenArgs.hs 
@@ -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
− utils/GenArgs/SHE.hs 
@@ -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
− utils/TestTypes.hs 
@@ -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)
− utils/Tests.hs 
@@ -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
− utils/Utils.hs 
@@ -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))