Skip to content
Snippets Groups Projects
Commit df6bf902 authored by Jean-Paul Calderone's avatar Jean-Paul Calderone
Browse files

[wip] try to get Ristretto involved

parent 5afa4358
Branches
No related tags found
1 merge request!22Ristretto-flavored PrivacyPass
...@@ -16,6 +16,7 @@ cabal-version: >=1.10 ...@@ -16,6 +16,7 @@ cabal-version: >=1.10
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: PaymentServer.Processors.Stripe exposed-modules: PaymentServer.Processors.Stripe
, PaymentServer.Ristretto
, PaymentServer.Issuer , PaymentServer.Issuer
, PaymentServer.Persistence , PaymentServer.Persistence
, PaymentServer.Redemption , PaymentServer.Redemption
...@@ -35,6 +36,7 @@ library ...@@ -35,6 +36,7 @@ library
, cryptonite , cryptonite
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wmissing-import-lists -Wunused-imports ghc-options: -Wmissing-import-lists -Wunused-imports
pkgconfig-depends: ristretto
executable PaymentServer-exe executable PaymentServer-exe
hs-source-dirs: app hs-source-dirs: app
...@@ -76,6 +78,7 @@ test-suite PaymentServer-test ...@@ -76,6 +78,7 @@ test-suite PaymentServer-test
, tasty-discover , tasty-discover
, tasty-quickcheck , tasty-quickcheck
, tasty-hspec , tasty-hspec
, tasty-wai
, servant-server , servant-server
, containers , containers
, unordered-containers , unordered-containers
......
...@@ -10,13 +10,21 @@ module PaymentServer.Issuer ...@@ -10,13 +10,21 @@ module PaymentServer.Issuer
, ChallengeBypass(ChallengeBypass) , ChallengeBypass(ChallengeBypass)
, Issuer , Issuer
, trivialIssue , trivialIssue
, ristrettoIssue
) where ) where
import PaymentServer.Ristretto
( ristretto
)
import Data.Text import Data.Text
( Text ( Text
) )
-- | A public key corresponding to our private key. -- | A private key for signing.
type SigningKey = Text
-- | A public key corresponding to a SigningKey.
type PublicKey = Text type PublicKey = Text
-- | A cryptographic signature of a blinded token created using our private -- | A cryptographic signature of a blinded token created using our private
...@@ -38,13 +46,19 @@ data ChallengeBypass = ...@@ -38,13 +46,19 @@ data ChallengeBypass =
-- | An issuer accepts a list of blinded tokens and returns signatures of -- | 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 -- those tokens along with proof that it used a particular key to construct
-- the signatures. -- the signatures.
type Issuer = [BlindedToken] -> ChallengeBypass type Issuer = [BlindedToken] -> IO ChallengeBypass
-- | trivialIssue makes up and returns some nonsense values that satisfy the -- | trivialIssue makes up and returns some nonsense values that satisfy the
-- structural requirements but not the semantic ones. -- structural requirements but not the semantic ones.
trivialIssue :: Issuer trivialIssue :: Issuer
trivialIssue tokens = trivialIssue tokens =
return $
ChallengeBypass ChallengeBypass
"fake-public-key" "fake-public-key"
(replicate (length tokens) "fake-signature") (replicate (length tokens) "fake-signature")
"fake-proof" "fake-proof"
ristrettoIssue :: SigningKey -> Issuer
ristrettoIssue signingKey tokens = do
(publicKey, tokens, proof) <- ristretto signingKey tokens
return $ ChallengeBypass publicKey tokens proof
...@@ -123,10 +123,8 @@ redeem issue database (Redeem voucher tokens) = do ...@@ -123,10 +123,8 @@ redeem issue database (Redeem voucher tokens) = do
result <- liftIO $ PaymentServer.Persistence.redeemVoucher database voucher fingerprint result <- liftIO $ PaymentServer.Persistence.redeemVoucher database voucher fingerprint
case result of case result of
Left err -> throwError jsonErr400 Left err -> throwError jsonErr400
Right () -> Right () -> do
let (ChallengeBypass key signatures proof) <- liftIO $ issue tokens
(ChallengeBypass key signatures proof) = issue tokens
in
return $ Succeeded key signatures proof return $ Succeeded key signatures proof
-- | Compute a cryptographic hash (fingerprint) of a list of tokens which can -- | Compute a cryptographic hash (fingerprint) of a list of tokens which can
......
...@@ -39,6 +39,7 @@ packages: ...@@ -39,6 +39,7 @@ packages:
# (e.g., acme-missiles-0.3) # (e.g., acme-missiles-0.3)
extra-deps: extra-deps:
- "stripe-core-2.5.0" - "stripe-core-2.5.0"
- "tasty-wai-0.1.1.0@sha256:44377c82bf1523c972fa361ea3d708fc423978dafc1d3bf2c6d9a2571ec69a08"
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}
...@@ -63,10 +64,3 @@ extra-deps: ...@@ -63,10 +64,3 @@ extra-deps:
# #
# Allow a newer minor version of GHC than the snapshot specifies # Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor # compiler-check: newer-minor
# https://docs.haskellstack.org/en/stable/nix_integration/#additions-to-your-stackyaml
nix:
enable: true
packages:
- "zlib"
...@@ -40,8 +40,13 @@ import Test.Hspec.Wai ...@@ -40,8 +40,13 @@ import Test.Hspec.Wai
, shouldRespondWith , shouldRespondWith
, liftIO , liftIO
) )
import Test.QuickCheck
( ioProperty
)
import Test.Hspec.Wai.QuickCheck import Test.Hspec.Wai.QuickCheck
( property ( Testable(toProperty)
, WaiProperty(unWaiProperty)
, property
) )
import Test.QuickCheck.Instances.Text () import Test.QuickCheck.Instances.Text ()
import Util.Spec import Util.Spec
...@@ -128,30 +133,27 @@ spec_redemption = parallel $ do ...@@ -128,30 +133,27 @@ spec_redemption = parallel $ do
propertyRedeem path voucher secondTokens 400 propertyRedeem path voucher secondTokens 400
describe "redemption" $ do -- describe "redemption" $ do
with (return $ app trivialIssue (RefuseRedemption NotPaid)) $ -- with (return $ app trivialIssue (RefuseRedemption NotPaid)) $
it "receives a failure response when the voucher is not paid" $ property $ -- it "receives a failure response when the voucher is not paid" $ property $
\(voucher :: Voucher) (tokens :: [BlindedToken]) -> -- \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
propertyRedeem path voucher tokens 400 -- propertyRedeem path voucher tokens 400
{ matchBody = matchJSONBody Failed -- { matchBody = matchJSONBody Failed
-- major/minor, fine. charset=utf-8... okay. but really this is -- -- major/minor, fine. charset=utf-8... okay. but really this is
-- overspecified by encoding the exact byte sequence. I'd rather -- -- overspecified by encoding the exact byte sequence. I'd rather
-- assert semantic equality. -- -- assert semantic equality.
, matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"] -- , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
} -- }
with (return $ app trivialIssue PermitRedemption) $ -- with (return $ app trivialIssue PermitRedemption) $
it "receive a success response when redemption succeeds" $ property $ -- it "receive a success response when redemption succeeds" $ property
\(voucher :: Voucher) (tokens :: [BlindedToken]) -> -- \(voucher :: Voucher) (tokens :: [BlindedToken]) -> do
let -- (ChallengeBypass key signatures proof) <- trivialIssue tokens
(ChallengeBypass key signatures proof) = trivialIssue tokens -- return $
in -- propertyRedeem path voucher tokens 200
propertyRedeem path voucher tokens 200 -- { matchBody = matchJSONBody $ Succeeded key signatures proof
-- TODO: Get some real crypto involved to be able to replace these -- , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
-- dummy values. -- }
{ matchBody = matchJSONBody $ Succeeded key signatures proof
, matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
}
-- it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $ -- it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $
-- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) -> -- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment