protocol: add key derivation

diff --git a/hjugement-protocol/Protocol/Credential.hs b/hjugement-protocol/Protocol/Credential.hs
index 43174282dca848ecc44c341d492fbd5d5051436e..7d851078bb72fc11d9e75e3e5fcc059aff7af459 100644 (file)
--- a/hjugement-protocol/Protocol/Credential.hs
+++ b/hjugement-protocol/Protocol/Credential.hs
@@ -1,21 +1,28 @@
 module Protocol.Credential where
 
 import Control.Monad (Monad(..), replicateM)
+import Data.Bits
 import Data.Bool
 import Data.Char (Char)
-import Data.Eq (Eq(..))
 import Data.Either (Either(..))
+import Data.Eq (Eq(..))
 import Data.Function (($))
 import Data.Functor ((<$>))
 import Data.Int (Int)
 import Data.Maybe (maybe)
+import Data.Ord (Ord(..))
 import Data.Text (Text)
-import Prelude (Integral(..), fromIntegral)
+import Numeric.Natural (Natural)
+import Prelude (Integral(..), fromIntegral, div)
 import Text.Show (Show)
 import qualified Control.Monad.Trans.State.Strict as S
+import qualified Crypto.KDF.PBKDF2 as Crypto
+import qualified Data.ByteArray as ByteArray
+import qualified Data.ByteString as BS
 import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import qualified System.Random as Random
 
 import Protocol.Arithmetic
@@ -78,3 +85,53 @@ data CredentialError
  |   CredentialError_Checksum
  |   CredentialError_Length
  deriving (Eq, Show)
+
+-- ** Type 'UUID'
+newtype UUID = UUID Text
+ deriving (Eq,Ord,Show)
+
+-- | @'randomUUID'@ generates a random 'UUID'.
+randomUUID ::
+ Monad m =>
+ Random.RandomGen r =>
+ S.StateT r m UUID
+randomUUID = do
+       rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
+       let (tot, cs) = List.foldl' (\(acc,ds) d ->
+                       ( acc * tokenBase + d
+                       , charOfDigit d : ds )
+                ) (zero::Int, []) rs
+       return $ UUID $ Text.reverse $ Text.pack cs
+       where
+       charOfDigit = (credentialAlphabet List.!!)
+
+-- ** Type 'SecretKey'
+type SecretKey = E
+
+-- | @('secretKey' uuid cred)@ returns the 'SecretKey'
+-- derived from given 'uuid' and 'cred'
+-- using 'Crypto.fastPBKDF2_SHA256'.
+secretKey :: SubGroup q => UUID -> Credential -> SecretKey q
+secretKey (UUID uuid) (Credential cred) =
+       inE $ BS.foldl'
+        (\acc b -> acc`shiftL`3 + fromIntegral b)
+        (0::Natural)
+        (ByteArray.convert deriv)
+       where
+       deriv :: BS.ByteString
+       deriv =
+               Crypto.fastPBKDF2_SHA256
+                Crypto.Parameters
+                { Crypto.iterCounts   = 1000
+                , Crypto.outputLength = 256 `div` 8
+                }
+                (Text.encodeUtf8 cred)
+                (Text.encodeUtf8 uuid)
+
+-- ** Type 'PublicKey'
+type PublicKey = G
+
+-- | @('publicKey' secKey)@ returns the 'PublicKey'
+-- derived from given 'SecretKey' in @('SubGroup' q)@.
+publicKey :: SubGroup q => SecretKey q -> PublicKey q
+publicKey = (groupGen ^)

diff --git a/hjugement-protocol/Protocol/Election.hs b/hjugement-protocol/Protocol/Election.hs
index 13ed300f55d9ce85975edcaec577bceec78e67ba..265c238c803098e08f617f9def91a21fac28fe55 100644 (file)
--- a/hjugement-protocol/Protocol/Election.hs
+++ b/hjugement-protocol/Protocol/Election.hs
@@ -17,6 +17,7 @@ import Data.Semigroup (Semigroup(..))
 import Data.String (IsString(..))
 import Data.Text (Text)
 import Data.Tuple (fst, snd, uncurry)
+import Numeric.Natural (Natural)
 import GHC.TypeNats
 import Text.Show (Show(..))
 import qualified Control.Monad.Trans.State.Strict as S
@@ -24,6 +25,7 @@ import qualified Data.ByteString as BS
 import qualified Data.List as List
 
 import Protocol.Arithmetic
+import Protocol.Credential
 import Utils.MeasuredList as ML
 import qualified Utils.Natural as Nat
 import qualified Utils.Constraint as Constraint
@@ -45,10 +47,6 @@ instance SubGroup q => Additive (Encryption q) where
         (encryption_nonce x * encryption_nonce y)
         (encryption_vault x * encryption_vault y)
 
--- ** Type 'PublicKey'
-type PublicKey = G
--- ** Type 'SecretKey'
-type SecretKey = E
 -- *** Type 'SecretNonce'
 type SecretNonce = E
 -- ** Type 'ZKP'
@@ -314,10 +312,6 @@ data Election quests choices mini maxi q = Election
  , election_hash        :: Hash
  } deriving (Eq,Show)
 
--- ** Type 'UUID'
-newtype UUID = UUID Text
- deriving (Eq,Ord,Show)
-
 -- ** Type 'Hash'
 newtype Hash = Hash Text
  deriving (Eq,Ord,Show)

diff --git a/hjugement-protocol/test/HUnit/Credential.hs b/hjugement-protocol/test/HUnit/Credential.hs
index 036a2a73e9d84e05244e3af6073644d31707b924..8267b651771b128729ff39b803c2f0e3d3500370 100644 (file)
--- a/hjugement-protocol/test/HUnit/Credential.hs
+++ b/hjugement-protocol/test/HUnit/Credential.hs
@@ -2,9 +2,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 module HUnit.Credential where
 
+import Control.Applicative (Applicative(..))
 import qualified Control.Monad.Trans.State.Strict as S
 import qualified System.Random as Random
 
+import Protocol.Arithmetic
 import Protocol.Credential
 import HUnit.Utils
 
@@ -15,6 +17,11 @@ hunit = testGroup "Credential"
                S.evalState randomCredential (Random.mkStdGen 0) @?=
                        Credential "xLcs7ev6Jy6FHHE"
         ]
+ , testGroup "randomUUID"
+        [ testCase "0" $
+               S.evalState randomUUID (Random.mkStdGen 0) @?=
+                       UUID "xLcs7ev6Jy6FHH"
+        ]
  , testGroup "readCredential" $
                let (==>) inp exp =
                        testCase (show inp) $ readCredential inp @?= exp in
@@ -29,4 +36,18 @@ hunit = testGroup "Credential"
         , "xLcs7ev6Jy6FHHF"  ==> Left CredentialError_Checksum
         , "xLcs7ev6Jy6FHHE"  ==> Right (Credential "xLcs7ev6Jy6FHHE")
         ]
+ , testGroup "secretKey" $
+        [ testSecretKey @WeakParams 0 $ E (F 122)
+        , testSecretKey @WeakParams 1 $ E (F 35)
+        , testSecretKey @BeleniosParams 0 $ E (F 2317630607062989137269685509390)
+        , testSecretKey @BeleniosParams 1 $ E (F 1968146140481358915910346867611)
+        ]
  ]
+
+testSecretKey :: forall q. SubGroup q => Int -> E q -> TestTree
+testSecretKey seed exp =
+       let (uuid@(UUID u), cred@(Credential c)) =
+               (`S.evalState` Random.mkStdGen seed) $
+                       (,) <$> randomUUID <*> randomCredential in
+       testCase (show (u,c)) $
+               secretKey @q uuid cred @?= exp