Ristretto happy-path, at least.

It's total amateur hour but that's what I am so who is surprised?

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

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 ) )

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.

src/PaymentServer/Ristretto.hs

+{-# 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.