diff --git a/Network/CryptoConditions.hs b/Network/CryptoConditions.hs --- a/Network/CryptoConditions.hs +++ b/Network/CryptoConditions.hs @@ -15,7 +15,6 @@ , ed25519Condition , preimageCondition , fulfillEd25519 - , readStandardFulfillment ) where import qualified Crypto.PubKey.Ed25519 as Ed2 @@ -62,11 +61,11 @@ getFingerprint (Prefix pre mml c) = prefixFingerprint pre mml c getFingerprint (Anon _ fp _ _) = fp - getFulfillment (Threshold t subs) = thresholdFulfillment t subs - getFulfillment (Ed25519 pk msig) = ed25519Fulfillment pk msig - getFulfillment (Preimage pre) = Just $ preimageFulfillment pre - getFulfillment (Prefix pre mml c) = prefixFulfillment pre mml c - getFulfillment (Anon _ _ _ _) = Nothing + getFulfillmentASN (Threshold t subs) = thresholdFulfillmentASN t subs + getFulfillmentASN (Ed25519 pk msig) = ed25519FulfillmentASN pk <$> msig + getFulfillmentASN (Preimage pre) = Just $ preimageFulfillmentASN pre + getFulfillmentASN (Prefix pre mml c) = prefixFulfillmentASN pre mml c + getFulfillmentASN (Anon _ _ _ _) = Nothing getSubtypes (Threshold _ sts) = thresholdSubtypes sts getSubtypes (Anon _ _ _ sts) = sts @@ -76,7 +75,7 @@ parseFulfillment 0 = parsePreimage Preimage parseFulfillment 1 = parsePrefix Prefix parseFulfillment 2 = parseThreshold Threshold - parseFulfillment 4 = parseEd25519 Ed25519 + parseFulfillment 4 = parseEd25519 (\a b -> Ed25519 a (Just b)) verifyMessage (Preimage image) = verifyPreimage image verifyMessage (Prefix pre mml cond) = verifyPrefix pre mml cond @@ -109,10 +108,6 @@ fulfillEd25519 pk sk msg (Prefix pre mml sub) = Prefix pre mml $ fulfillEd25519 pk sk (pre <> msg) sub fulfillEd25519 _ _ _ c = c - - -readStandardFulfillment :: Fulfillment -> Either String Condition -readStandardFulfillment = readFulfillment instance ToJSON Condition where diff --git a/Network/CryptoConditions/Encoding.hs b/Network/CryptoConditions/Encoding.hs --- a/Network/CryptoConditions/Encoding.hs +++ b/Network/CryptoConditions/Encoding.hs @@ -4,10 +4,11 @@ ( x690SortAsn , b64EncodeStripped , b64DecodeStripped - , asnSeq , bytesOfUInt , uIntFromBytes - , fiveBellsContainer + , asnData + , asnChoice + , asnSequence , toData , toKey , parseASN1 @@ -54,14 +55,18 @@ x690SortAsn = sortOn (\a -> let b = encodeASN1' DER a in (BS.length b, b)) -asnSeq :: ASN1ConstructionType -> [ASN1] -> [ASN1] -asnSeq c args = [Start c] ++ args ++ [End c] +asnSequence :: ASN1ConstructionType -> [ASN1] -> [ASN1] +asnSequence c args = [Start c] ++ args ++ [End c] -fiveBellsContainer :: Integral i => i -> [BS.ByteString] -> [ASN1] -fiveBellsContainer tid bs = +asnChoice :: Integral i => i -> [ASN1] -> [ASN1] +asnChoice tid asn = let c = Container Context $ fromIntegral tid - in asnSeq c [Other Context i s | (i,s) <- zip [0..] bs] + in asnSequence c asn + + +asnData :: [BS.ByteString] -> [ASN1] +asnData bss = [Other Context i s | (i,s) <- zip [0..] bss] bytesOfUInt :: Integer -> [Word8] diff --git a/Network/CryptoConditions/Impl.hs b/Network/CryptoConditions/Impl.hs --- a/Network/CryptoConditions/Impl.hs +++ b/Network/CryptoConditions/Impl.hs @@ -36,8 +36,8 @@ class Show c => IsCondition c where getCost :: c -> Int getType :: c -> ConditionType - getFingerprint :: c -> BS.ByteString - getFulfillment :: c -> Maybe BS.ByteString + getFingerprint :: c -> Fingerprint + getFulfillmentASN :: c -> Maybe [ASN1] getSubtypes :: c -> Set.Set ConditionType parseFulfillment :: Int -> ParseASN1 c verifyMessage :: c -> Message -> Bool @@ -53,18 +53,18 @@ encodeCondition :: IsCondition c => c -> BS.ByteString -encodeCondition = encodeASN1' DER . encodeConditionASN +encodeCondition = encodeASN1' DER . getConditionASN -encodeConditionASN :: IsCondition c => c -> [ASN1] -encodeConditionASN c = +getConditionASN :: IsCondition c => c -> [ASN1] +getConditionASN c = let ct = getType c fingerprint = getFingerprint c costBs = BS.pack $ bytesOfUInt $ fromIntegral $ getCost c subtypes = toBitString $ Set.map typeId $ getSubtypes c body = [fingerprint, costBs] ++ if hasSubtypes ct then [subtypes] else [] - in fiveBellsContainer (typeId ct) body + in asnChoice (typeId ct) $ asnData body getConditionURI :: IsCondition c => c -> T.Text @@ -80,23 +80,26 @@ <> cost <> subtypes -getFulfillmentBase64 :: IsCondition c => c -> Maybe T.Text -getFulfillmentBase64 = - fmap (decodeUtf8 . B64.encode) . getFulfillment +encodeFulfillment :: IsCondition c => c -> Maybe Fulfillment +encodeFulfillment cond = encodeASN1' DER <$> getFulfillmentASN cond -readFulfillment :: IsCondition c => Fulfillment -> Either String c -readFulfillment bs = parseASN1 bs parsePoly +encodeFulfillmentBase64 :: IsCondition c => c -> Maybe T.Text +encodeFulfillmentBase64 cond = decodeUtf8 . B64.encode <$> encodeFulfillment cond -readFulfillmentBase64 :: IsCondition c => Fulfillment -> Either String c -readFulfillmentBase64 = readFulfillment . B64.decodeLenient +decodeFulfillment :: IsCondition c => Fulfillment -> Either String c +decodeFulfillment bs = parseASN1 bs parsePoly -readCondition :: IsCondition c => BS.ByteString -> Either String c -readCondition bs = parseASN1 bs parseCondition +decodeFulfillmentBase64 :: IsCondition c => Fulfillment -> Either String c +decodeFulfillmentBase64 = decodeFulfillment . B64.decodeLenient +decodeCondition :: IsCondition c => BS.ByteString -> Either String c +decodeCondition bs = parseASN1 bs parseCondition + + parsePoly :: IsCondition c => ParseASN1 c parsePoly = withContainerContext parseFulfillment @@ -150,9 +153,8 @@ preimageType = CT 0 "preimage-sha-256" False "sha-256" -preimageFulfillment :: BS.ByteString -> Fulfillment -preimageFulfillment pre = encodeASN1' DER body - where body = fiveBellsContainer (typeId preimageType) [pre] +preimageFulfillmentASN :: BS.ByteString -> [ASN1] +preimageFulfillmentASN pre = asnChoice 0 $ asnData [pre] preimageCost :: BS.ByteString -> Int @@ -187,27 +189,19 @@ prefixFingerprint :: IsCondition c => Prefix -> Int -> c -> Fingerprint -prefixFingerprint pre mml cond = sha256 body - where body = encodeASN1' DER asn - mmlbs = BS.pack $ bytesOfUInt $ fromIntegral mml - condAsn = encodeConditionASN cond - asn = asnSeq Sequence $ - [ Other Context 0 pre - , Other Context 1 mmlbs - ] ++ asnSeq (Container Context 2) condAsn +prefixFingerprint pre mml cond = hashASN $ asn + where + mmlbs = BS.pack $ bytesOfUInt $ fromIntegral mml + condAsn = getConditionASN cond + asn = asnSequence Sequence $ asnData [pre, mmlbs] ++ asnChoice 2 condAsn -prefixFulfillment :: IsCondition c => Prefix -> Int -> c -> Maybe Fulfillment -prefixFulfillment pre mml cond = +prefixFulfillmentASN :: IsCondition c => Prefix -> Int -> c -> Maybe [ASN1] +prefixFulfillmentASN pre mml cond = let mmlbs = BS.pack $ bytesOfUInt $ fromIntegral mml - msubffill = getFulfillment cond - getAsn subffill = - let subAsn = either (error . show) id $ decodeASN1' DER $ subffill - in asnSeq (Container Context 1) $ - [ Other Context 0 pre - , Other Context 1 mmlbs - ] ++ asnSeq (Container Context 2) subAsn - in encodeASN1' DER . getAsn <$> msubffill + getAsn subasn = + asnChoice 1 $ asnData [pre, mmlbs] ++ asnChoice 2 subasn + in getAsn <$> getFulfillmentASN cond prefixSubtypes :: IsCondition c => c -> Set.Set ConditionType @@ -221,7 +215,7 @@ parsePrefix construct = do (pre, mmlbs) <- (,) <$> parseOther 0 <*> parseOther 1 let mml = fromIntegral $ uIntFromBytes $ BS.unpack mmlbs - cond <- onNextContainer (Container Context 2) parsePoly + cond <- parseContainer 2 parsePoly pure $ construct pre mml cond @@ -239,19 +233,15 @@ thresholdType = CT 2 "threshold-sha-256" True "sha-256" -thresholdFulfillment :: IsCondition c => Word16 -> [c] -> Maybe Fulfillment -thresholdFulfillment t subs = +thresholdFulfillmentASN :: IsCondition c => Word16 -> [c] -> Maybe [ASN1] +thresholdFulfillmentASN t subs = let ti = fromIntegral t - withFf = zip subs (getFulfillment <$> subs) + withFf = zip subs (getFulfillmentASN <$> subs) byCost = sortOn ffillCost withFf ffills = take ti $ catMaybes $ snd <$> byCost - conds = encodeConditionASN . fst <$> drop ti byCost - ffills' = either (error . show) id . decodeASN1' DER <$> ffills - asn = asnSeq (Container Context 2) $ - asnSeq (Container Context 0) (concat ffills') ++ - asnSeq (Container Context 1) (concat conds) - encoded = encodeASN1' DER asn - in if length ffills == ti then Just encoded else Nothing + conds = getConditionASN . fst <$> drop ti byCost + asn = asnChoice 2 $ asnChoice 0 (concat ffills) ++ asnChoice 1 (concat conds) + in if length ffills == ti then Just asn else Nothing where -- order by has ffill then cost of ffill ffillCost (c, Just _) = (0::Int, getCost c) @@ -260,18 +250,16 @@ thresholdFingerprint :: IsCondition c => Word16 -> [c] -> Fingerprint thresholdFingerprint t subs = - let asns = encodeConditionASN <$> subs + let asns = getConditionASN <$> subs in thresholdFingerprintFromAsns t asns thresholdFingerprintFromAsns :: Word16 -> [[ASN1]] -> Fingerprint thresholdFingerprintFromAsns t asns = let subs' = x690SortAsn asns - c = Container Context 1 - asn = asnSeq Sequence $ - [ Other Context 0 (BS.pack $ bytesOfUInt $ fromIntegral t) - , Start c - ] ++ concat subs' ++ [End c] + asn = asnSequence Sequence $ + asnData [BS.pack $ bytesOfUInt $ fromIntegral t] ++ + asnChoice 1 (concat subs') in sha256 $ encodeASN1' DER asn @@ -290,8 +278,8 @@ parseThreshold :: IsCondition c => (Word16 -> [c] -> c) -> ParseASN1 c parseThreshold construct = do - ffills <- onNextContainer (Container Context 0) $ getMany parsePoly - conds <- onNextContainer (Container Context 1) $ getMany parseCondition + ffills <- parseContainer 0 $ getMany parsePoly + conds <- parseContainer 1 $ getMany parseCondition let t = fromIntegral $ length ffills pure $ construct t (conds ++ ffills) @@ -322,33 +310,26 @@ ed25519Fingerprint :: Ed2.PublicKey -> Fingerprint -ed25519Fingerprint pk = sha256 body - where body = encodeASN1' DER asn - asn = [ Start Sequence - , Other Context 0 $ toData pk - ] +ed25519Fingerprint pk = + hashASN $ asnSequence Sequence $ asnData [toData pk] -ed25519Fulfillment :: Ed2.PublicKey -> Maybe Ed2.Signature -> Maybe Fulfillment -ed25519Fulfillment pk msig = Just $ encodeASN1' DER body - where body = fiveBellsContainer (typeId ed25519Type) [toData pk, sig] - sig = maybe "" toData msig +ed25519FulfillmentASN :: Ed2.PublicKey -> Ed2.Signature -> [ASN1] +ed25519FulfillmentASN pk sig = asnChoice 4 $ asnData [toData pk, toData sig] -parseEd25519 :: (Ed2.PublicKey -> Maybe Ed2.Signature -> c) -> ParseASN1 c +parseEd25519 :: (Ed2.PublicKey -> Ed2.Signature -> c) -> ParseASN1 c parseEd25519 construct = do (bspk, bssig) <- (,) <$> parseOther 0 <*> parseOther 1 - let msig = case bssig of - "" -> pure Nothing - bs -> Just <$> (toKey (Ed2.signature bs)) either throwParseError pure $ construct <$> toKey (Ed2.publicKey bspk) - <*> msig + <*> toKey (Ed2.signature bssig) verifyEd25519 :: Ed2.PublicKey -> Ed2.Signature -> Message -> Bool verifyEd25519 pk = flip (Ed2.verify pk) + -------------------------------------------------------------------------------- -- Utilities @@ -357,6 +338,10 @@ sha256 a = BS.pack $ BA.unpack $ (hash a :: Digest SHA256) +hashASN :: [ASN1] -> Fingerprint +hashASN = sha256 . encodeASN1' DER + + withContainerContext :: (Int -> ParseASN1 a) -> ParseASN1 a withContainerContext fp = do asn <- getNext @@ -367,6 +352,10 @@ if end /= End c then throwParseError "Failed parsing end" else pure res other -> throwParseError ("Not a container context: " ++ show other) + + +parseContainer :: Int -> ParseASN1 a -> ParseASN1 a +parseContainer = onNextContainer . Container Context parseOther :: Int -> ParseASN1 BS.ByteString diff --git a/cryptoconditions.cabal b/cryptoconditions.cabal --- a/cryptoconditions.cabal +++ b/cryptoconditions.cabal @@ -1,5 +1,5 @@ name: cryptoconditions -version: 0.2.2.2 +version: 0.2.3.0 synopsis: Interledger Crypto-Conditions description: Please see README.md homepage: https://github.com/libscott/cryptoconditions-hs diff --git a/test/TestStandard.hs b/test/TestStandard.hs --- a/test/TestStandard.hs +++ b/test/TestStandard.hs @@ -37,12 +37,6 @@ , testFulfill "Test prefixed" $ Prefix "a" 20 ed2Alice - - , testCase "Test read fulfillment empty signatures" $ - let (Just ffillBin) = getFulfillment ed2Alice - (Right cond') = readFulfillment ffillBin - in assertEqual "Can decode unfulfilled fulfillment" ed2Alice cond' - ] @@ -53,12 +47,13 @@ let msg = umsg uri = getConditionURI cond badFfill = fulfillEd25519 pkAlice skEve umsg cond - (Just ffillBin) = getFulfillment badFfill + (Just ffillBin) = encodeFulfillment badFfill goodFfill = fulfillEd25519 pkAlice skAlice umsg cond - assertBool "can get fulfillment payload without signature" $ - Nothing /= getFulfillment cond - assertEqual "get uri from bad fulfillment" - (Right uri) $ getConditionURI <$> readStandardFulfillment ffillBin + econd = decodeFulfillment ffillBin :: Either String Condition + assertEqual "can not get fulfillment payload without signature" + Nothing $ encodeFulfillment cond + assertEqual "get uri from good fulfillment" + (Right uri) $ getConditionURI <$> econd assertBool "wrong sig right message does not validate" $ not $ validate uri badFfill msg assertBool "wrong msg right sig does not validate" $ diff --git a/test/TestVectors.hs b/test/TestVectors.hs --- a/test/TestVectors.hs +++ b/test/TestVectors.hs @@ -43,11 +43,11 @@ testVectors :: String -> TestTree testVectors file = testGroup file [ testCase "encodeCondition" $ encodeCondition cond @?= condBin - , testCase "getFulfillment" $ getFulfillment cond @?= Just ffillBin + , testCase "encodeFulfillment" $ encodeFulfillment cond @?= Just ffillBin , testCase "getConditionURI" $ getConditionURI cond @?= condUri , testCase "validate" $ validate condUri cond msg @?= True - , testCase "readCondition" $ - let econd = readCondition condBin :: Either String Condition + , testCase "decodeCondition" $ + let econd = decodeCondition condBin :: Either String Condition in (getConditionURI <$> econd) @?= Right condUri ] where