From 2491652926ea9a7e938466ab3a52fd242410e67b Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Thu, 12 Sep 2019 15:17:44 -0400
Subject: [PATCH] Ristretto happy-path, at least.
It's total amateur hour but that's what I am so who is surprised?
---
src/PaymentServer/Issuer.hs | 12 ++--
src/PaymentServer/Main.hs | 5 +-
src/PaymentServer/Redemption.hs | 16 ++++-
src/PaymentServer/Ristretto.hs | 114 ++++++++++++++++++++++++++------
4 files changed, 116 insertions(+), 31 deletions(-)
diff --git a/src/PaymentServer/Issuer.hs b/src/PaymentServer/Issuer.hs
index 267a488..8ed7eb4 100644
--- a/src/PaymentServer/Issuer.hs
+++ b/src/PaymentServer/Issuer.hs
@@ -46,13 +46,13 @@ data ChallengeBypass =
-- | An issuer accepts a list of blinded tokens and returns signatures of
-- those tokens along with proof that it used a particular key to construct
-- the signatures.
-type Issuer = [BlindedToken] -> IO ChallengeBypass
+type Issuer = [BlindedToken] -> IO (Maybe ChallengeBypass)
-- | trivialIssue makes up and returns some nonsense values that satisfy the
-- structural requirements but not the semantic ones.
trivialIssue :: Issuer
trivialIssue tokens =
- return $
+ return . Just $
ChallengeBypass
"fake-public-key"
(replicate (length tokens) "fake-signature")
@@ -65,5 +65,9 @@ ristrettoIssue
:: SigningKey -- ^ The key to provide to the PrivacyPass signer.
-> Issuer -- ^ An issuer using the given key.
ristrettoIssue signingKey tokens = do
- (publicKey, tokens, proof) <- ristretto signingKey tokens
- return $ ChallengeBypass publicKey tokens proof
+ issuance <- ristretto signingKey tokens
+ case issuance of
+ Right (publicKey, tokens, proof) -> return . Just $ ChallengeBypass publicKey tokens proof
+ Left err -> do
+ putStrLn . show $ err
+ return Nothing
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index 041ea9a..2613964 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -39,6 +39,7 @@ import Options.Applicative
, ParserInfo
, option
, auto
+ , str
, optional
, long
, help
@@ -82,7 +83,7 @@ sample = ServerConfig
<> help "Which issuer to use: trivial or ristretto"
<> showDefault
<> value Trivial )
- <*> optional (option auto
+ <*> optional (option str
( long "signing-key"
<> help "The base64 encoded signing key (ristretto only)"
<> showDefault ) )
@@ -91,7 +92,7 @@ sample = ServerConfig
<> help "Which database to use: sqlite3 or memory"
<> showDefault
<> value Memory )
- <*> optional ( option auto
+ <*> optional ( option str
( long "database-path"
<> help "Path to on-disk database (sqlite3 only)"
<> showDefault ) )
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
index eb16b7e..4eb5b29 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -54,6 +54,7 @@ import Crypto.Hash
)
import PaymentServer.Persistence
( VoucherDatabase(redeemVoucher)
+ , RedeemError(NotPaid, AlreadyRedeemed)
, Fingerprint
, Voucher
)
@@ -122,10 +123,19 @@ redeem issue database (Redeem voucher tokens) = do
let fingerprint = fingerprintFromTokens tokens
result <- liftIO $ PaymentServer.Persistence.redeemVoucher database voucher fingerprint
case result of
- Left err -> throwError jsonErr400
+ Left NotPaid -> do
+ liftIO $ putStrLn "Attempt to redeem unpaid voucher"
+ throwError jsonErr400
+ Left AlreadyRedeemed -> do
+ liftIO $ putStrLn "Attempt to double-spend paid voucher"
+ throwError jsonErr400
Right () -> do
- (ChallengeBypass key signatures proof) <- liftIO $ issue tokens
- return $ Succeeded key signatures proof
+ result <- liftIO $ issue tokens
+ case result of
+ Just (ChallengeBypass key signatures proof) ->
+ return $ Succeeded key signatures proof
+ Nothing ->
+ throwError jsonErr400
-- | Compute a cryptographic hash (fingerprint) of a list of tokens which can
-- be used as an identifier for this exact sequence of tokens.
diff --git a/src/PaymentServer/Ristretto.hs b/src/PaymentServer/Ristretto.hs
index 832e125..25ee3d3 100644
--- a/src/PaymentServer/Ristretto.hs
+++ b/src/PaymentServer/Ristretto.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE EmptyDataDecls #-}
@@ -6,13 +7,19 @@ module PaymentServer.Ristretto
, ristretto
) where
+import Control.Exception
+ ( bracket
+ , assert
+ )
import Data.Text
( Text
, unpack
+ , pack
)
import Foreign.Ptr
( Ptr
+ , nullPtr
)
import Foreign.C.String
( CString
@@ -23,6 +30,9 @@ import Foreign.C.String
import Foreign.Marshal.Alloc
( free
)
+import Foreign.Marshal.Array
+ ( withArray
+ )
data C_BlindedToken
data C_SignedToken
@@ -44,32 +54,92 @@ foreign import ccall "signing_key_sign" signing_key_sign :: Ptr C_SigningKey ->
foreign import ccall "signed_token_encode_base64" signed_token_encode_base64 :: Ptr C_SignedToken -> IO CString
-foreign import ccall "batch_dleq_proof_new" batch_dleq_proof_new :: Ptr C_BlindedToken -> Ptr C_SignedToken -> Int -> Ptr C_SigningKey -> IO (Ptr C_BatchDLEQProof)
+foreign import ccall "batch_dleq_proof_new" batch_dleq_proof_new :: Ptr (Ptr C_BlindedToken) -> Ptr (Ptr C_SignedToken) -> Int -> Ptr C_SigningKey -> IO (Ptr C_BatchDLEQProof)
foreign import ccall "batch_dleq_proof_encode_base64" batch_dleq_proof_encode_base64 :: Ptr C_BatchDLEQProof -> IO CString
foreign import ccall "batch_dleq_proof_destroy" batch_dleq_proof_destroy :: Ptr C_BatchDLEQProof -> IO ()
+-- | Private type to represent the return value of ristretto.
+type Issuance =
+ ( Text -- |^ The base64-encoded public key corresponding to the
+ -- signing key which generated the signatures.
+ , [Text] -- |^ A list of base64-encoded token signatures.
+ , Text -- |^ The base64-encoded batch DLEQ proof that the signatures
+ -- were made with the signing key corresponding to the public
+ -- key.
+ )
+
+data RistrettoFailure
+ = SigningKeyAllocation
+ | SigningKeyDecoding
+ | BlindedTokenAllocation
+ | BlindedTokenDecoding
+ | SignedTokenAllocation
+ | TokenSigning
+ | SignedTokenEncoding
+ | ProofCreation
+ | SignedTokenPeek
+ | PublicKeyLookup
+ | PublicKeyEncoding
+ deriving (Show, Eq)
+
+
ristretto
- :: Text -- ^ The base64 encoded signing key.
- -> [Text] -- ^ A list of the base64 blinded tokens.
- -> IO (Text, [Text], Text) -- ^ The base64 public key, list of base64 signed tokens, and the base64 proof.
-ristretto textSigningKey textTokens = do
- let stringSigningKey = unpack textSigningKey
- cStringSigningKey <- newCString stringSigningKey
- signingKey <- signing_key_decode_base64 cStringSigningKey
- let stringTokens = map unpack textTokens
- cStringTokens <- mapM newCString stringTokens
- blindedTokens <- mapM blinded_token_decode_base64 cStringTokens
- signedTokens <- mapM (signing_key_sign signingKey) blindedTokens
- -- encodedTokens <- map signed_token_encode_base64 signedTokens
- -- proof <- batch_dleq_proof_new blindedTokens signedTokens (length blindedTokens) signingKey
- -- encodedProof <- batch_dleq_proof_encode_base64 proof
- -- publicKey <- signing_key_get_public_key signingKey
- -- encodedPublicKey <- public_key_encode_base64 publicKey
- -- ChallengeBypass
- -- encodedPublicKey
- -- encodedTokens
- -- encodedProof
- return (mempty, [], mempty)
+ :: Text -- ^ The base64 encoded signing key.
+ -> [Text] -- ^ A list of the base64 blinded tokens.
+ -> IO (Either RistrettoFailure Issuance) -- ^ Left for an error, otherwise
+ -- Right with the ristretto results
+ristretto textSigningKey textTokens =
+ let
+ newProof blindedTokens signedTokens signingKey =
+ withArray blindedTokens $ \cBlindedTokensArray ->
+ withArray signedTokens $ \cSignedTokensArray ->
+ batch_dleq_proof_new cBlindedTokensArray cSignedTokensArray (length blindedTokens) signingKey
+
+ newEncodedProof blindedTokens signedTokens signingKey =
+ bracket (newProof blindedTokens signedTokens signingKey) batch_dleq_proof_destroy $ \proof ->
+ bracket (batch_dleq_proof_encode_base64 proof) free peekCString
+
+ stringSigningKey = unpack textSigningKey
+ stringTokens = map unpack textTokens
+ in
+ do
+ cStringSigningKey <- newCString stringSigningKey
+ case cStringSigningKey == nullPtr of
+ True -> return $ Left SigningKeyAllocation
+ False -> do
+ signingKey <- signing_key_decode_base64 cStringSigningKey
+ case signingKey == nullPtr of
+ True -> return $ Left SigningKeyDecoding
+ False -> do
+ cStringTokens <- mapM newCString stringTokens
+ case any (== nullPtr) cStringTokens of
+ True -> return $ Left BlindedTokenAllocation
+ False -> do
+ blindedTokens <- mapM blinded_token_decode_base64 cStringTokens
+ case any (== nullPtr) blindedTokens of
+ True -> return $ Left BlindedTokenDecoding
+ False -> do
+ signedTokens <- mapM (signing_key_sign signingKey) blindedTokens
+ case any (== nullPtr) signedTokens of
+ True -> return $ Left TokenSigning
+ False -> do
+ encodedCStringSignedTokens <- mapM signed_token_encode_base64 signedTokens
+ case any (== nullPtr) encodedCStringSignedTokens of
+ True -> return $ Left SignedTokenEncoding
+ False -> do
+ encodedSignedTokens <- mapM peekCString encodedCStringSignedTokens
+ encodedProof <- newEncodedProof blindedTokens signedTokens signingKey
+ publicKey <- signing_key_get_public_key signingKey
+ case publicKey == nullPtr of
+ True -> return $ Left PublicKeyLookup
+ False -> do
+ cStringEncodedPublicKey <- public_key_encode_base64 publicKey
+ case cStringEncodedPublicKey == nullPtr of
+ True -> return $ Left PublicKeyEncoding
+ False -> do
+ encodedPublicKey <- peekCString cStringEncodedPublicKey
+ return $ Right (pack encodedPublicKey, map pack encodedSignedTokens, pack encodedProof)
+
-- | randomSigningKey generates a new signing key at random and returns it
-- encoded as a base64 string.
--
GitLab