diff --git a/Network/CryptoConditions.hs b/Network/CryptoConditions.hs --- a/Network/CryptoConditions.hs +++ b/Network/CryptoConditions.hs @@ -44,6 +44,7 @@ getType (Anon 1 _ _ _) = prefixType getType (Anon 2 _ _ _) = thresholdType getType (Anon 4 _ _ _) = ed25519Type + getType (Anon n _ _ cts) = CT n "UNKNOWN" (cts == mempty) "" getType (Threshold _ _) = thresholdType getType (Ed25519 _ _) = ed25519Type getType (Preimage _) = preimageType @@ -68,14 +69,15 @@ getFulfillmentASN (Anon _ _ _ _) = Nothing getSubtypes (Threshold _ sts) = thresholdSubtypes sts - getSubtypes (Anon _ _ _ sts) = sts - getSubtypes (Prefix _ _ c) = prefixSubtypes c - getSubtypes _ = mempty + getSubtypes (Anon _ _ _ sts) = sts + getSubtypes (Prefix _ _ c) = prefixSubtypes c + getSubtypes _ = mempty parseFulfillment 0 = parsePreimage Preimage parseFulfillment 1 = parsePrefix Prefix parseFulfillment 2 = parseThreshold Threshold parseFulfillment 4 = parseEd25519 (\a b -> Ed25519 a (Just b)) + parseFulfillment n = fail ("unknown condition type: " ++ show n) verifyMessage (Preimage image) = verifyPreimage image verifyMessage (Prefix pre mml cond) = verifyPrefix pre mml cond @@ -115,15 +117,16 @@ toJSON (Ed25519 pk msig) = toJsonEd25519 pk msig toJSON (Prefix pre mml c) = toJsonPrefix pre mml c toJSON (Preimage img) = toJsonPreimage img + toJSON c@(Anon _ _ _ _) = toJsonAnon c instance FromJSON Condition where parseJSON = withObject "condition" $ \o -> do - typeName <- o .: "type" - let method = case typeName of + name <- o .: "type" + let method = case name of "preimage-sha-256" -> CCJ.parseJsonPreimage Preimage "prefix-sha-256" -> parseJsonPrefix Prefix "threshold-sha-256" -> parseJsonThreshold Threshold "ed25519-sha-256" -> parseJsonEd25519 Ed25519 - _ -> fail ("Unknown Crypto-Condition type: " ++ typeName) + _ -> fail ("Unknown Crypto-Condition type: " ++ name) method o diff --git a/Network/CryptoConditions/Encoding.hs b/Network/CryptoConditions/Encoding.hs --- a/Network/CryptoConditions/Encoding.hs +++ b/Network/CryptoConditions/Encoding.hs @@ -59,7 +59,7 @@ asnSequence c args = [Start c] ++ args ++ [End c] -asnChoice :: Integral i => i -> [ASN1] -> [ASN1] +asnChoice :: Int -> [ASN1] -> [ASN1] asnChoice tid asn = let c = Container Context $ fromIntegral tid in asnSequence c asn @@ -98,18 +98,24 @@ toData = BS.pack . BA.unpack --- TODO: Support larger bitstrings - toBitString :: Set.Set Int -> BS.ByteString toBitString types = - let words = Set.map fromIntegral types - bitArray = foldl bitArraySetBit (BitArray 32 "\0") words + let ids = Set.map fromIntegral types maxId = foldl max 0 types + bitArray = foldl bitArraySetBit (newBitArray maxId) ids bitsUnused = fromIntegral $ 7 - mod maxId 8 in BS.singleton bitsUnused <> bitArrayGetData bitArray +newBitArray :: Int -> BitArray +newBitArray maxId = + let n = ceiling $ (fromIntegral maxId+1) / 8 + in BitArray (n*8) (BS.replicate (fromIntegral n) 0) + + fromBitString :: BS.ByteString -> Set.Set Int fromBitString maskbs = Set.fromList $ - let [_, w] = fromIntegral <$> BS.unpack maskbs :: [Int] - in filter (\i -> 0 /= w .&. (shiftL 1 (7-i))) [0..7] + let bytes = BS.tail maskbs + capacity = 8 * BS.length bytes + ba = BitArray (fromIntegral capacity) bytes + in [i | i <- [0..capacity-1], bitArrayGetBit ba (fromIntegral i)] diff --git a/Network/CryptoConditions/Impl.hs b/Network/CryptoConditions/Impl.hs --- a/Network/CryptoConditions/Impl.hs +++ b/Network/CryptoConditions/Impl.hs @@ -4,30 +4,26 @@ module Network.CryptoConditions.Impl where -import Crypto.Hash +import Crypto.Hash import qualified Crypto.PubKey.Ed25519 as Ed2 -import Control.Monad (when) - -import qualified Data.Aeson.Types as Aeson -import Data.ASN1.BinaryEncoding -import Data.ASN1.BinaryEncoding.Raw -import Data.ASN1.Encoding -import Data.ASN1.Parse -import Data.ASN1.Types -import Data.Bits +import Data.ASN1.BinaryEncoding +import Data.ASN1.BinaryEncoding.Raw +import Data.ASN1.Encoding +import Data.ASN1.Parse +import Data.ASN1.Types import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64 -import Data.List (sortOn) -import Data.Maybe -import Data.Monoid +import Data.List (sortOn) +import Data.Maybe +import Data.Monoid import qualified Data.Set as Set import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import Data.Word +import Data.Text.Encoding (decodeUtf8) +import Data.Word -import Network.CryptoConditions.Encoding +import Network.CryptoConditions.Encoding -------------------------------------------------------------------------------- @@ -222,7 +218,7 @@ verifyPrefix :: IsCondition c => Prefix -> Int -> c -> Message -> Bool verifyPrefix prefix mml cond msg = let ok = mml >= BS.length msg - in verifyMessage cond (prefix <> msg) + in ok && verifyMessage cond (prefix <> msg) -------------------------------------------------------------------------------- @@ -260,7 +256,7 @@ asn = asnSequence Sequence $ asnData [BS.pack $ bytesOfUInt $ fromIntegral t] ++ asnChoice 1 (concat subs') - in sha256 $ encodeASN1' DER asn + in hashASN asn thresholdSubtypes :: IsCondition c => [c] -> Set.Set ConditionType @@ -365,4 +361,4 @@ (Other Context i bs) -> if n == i then pure bs else throwParseError $ "Invalid context id: " ++ show (n,i) - other -> throwParseError "agh" -- TODO + notOther -> throwParseError ("Unexpected element: " ++ show notOther) diff --git a/Network/CryptoConditions/Json.hs b/Network/CryptoConditions/Json.hs --- a/Network/CryptoConditions/Json.hs +++ b/Network/CryptoConditions/Json.hs @@ -5,6 +5,7 @@ , parseJsonPrefix , parseJsonThreshold , parseJsonEd25519 + , toJsonAnon , toJsonPreimage , toJsonPrefix , toJsonThreshold @@ -32,24 +33,24 @@ -- Parsing -- -parseJsonThreshold :: (IsCondition c, FromJSON c) => (Word16 -> [c] -> c) -> Object -> Parser c +parseJsonThreshold :: FromJSON c => (Word16 -> [c] -> c) -> Object -> Parser c parseJsonThreshold f obj = f <$> obj .: "threshold" <*> obj .: "subfulfillments" -parseJsonEd25519 :: IsCondition c => (PublicKey -> Maybe Signature -> c) -> Object -> Parser c +parseJsonEd25519 :: (PublicKey -> Maybe Signature -> c) -> Object -> Parser c parseJsonEd25519 f obj = do pub <- obj .: "publicKey" >>= parseKey publicKey msig <- obj .:? "signature" >>= mapM (parseKey signature) pure $ f pub msig -parseJsonPrefix :: (IsCondition c, FromJSON c) => (ByteString -> Int -> c -> c) -> Object -> Parser c +parseJsonPrefix :: FromJSON c => (ByteString -> Int -> c -> c) -> Object -> Parser c parseJsonPrefix f obj = do pre <- obj .: "prefix" >>= fromB64 f pre <$> obj .: "maxMessageLength" <*> obj .: "subfulfillment" -parseJsonPreimage :: IsCondition c => (ByteString -> c) -> Object -> Parser c +parseJsonPreimage :: (ByteString -> c) -> Object -> Parser c parseJsonPreimage f obj = f <$> (obj .: "preimage" >>= fromB64) @@ -61,15 +62,16 @@ toJsonPreimage img = object ["type" .= String "preimage-sha-256", "preimage" .= toB64 img] -toJsonPrefix :: (IsCondition c, ToJSON c) => ByteString -> Int -> c -> Value +toJsonPrefix :: ToJSON c => ByteString -> Int -> c -> Value toJsonPrefix pre mml sub = object [ "type".= String "prefix-sha-256" , "prefix" .= toB64 pre + , "maxMessageLength" .= mml , "subfulfillment" .= sub ] -toJsonThreshold :: (IsCondition c, ToJSON c) => Word16 -> [c] -> Value +toJsonThreshold :: ToJSON c => Word16 -> [c] -> Value toJsonThreshold threshold subs = object [ "type" .= String "threshold-sha-256" , "threshold" .= threshold @@ -81,6 +83,13 @@ toJsonEd25519 pk msig = let sigItem = maybe [] (\sig -> ["signature" .= keyToJson sig]) msig in object $ ["type" .= String "ed25519-sha-256", "publicKey" .= keyToJson pk] ++ sigItem + + +toJsonAnon :: IsCondition c => c -> Value +toJsonAnon cond = + object [ "type" .= (typeName $ getType cond) + , "uri" .= getConditionURI cond + ] -- Util diff --git a/cryptoconditions.cabal b/cryptoconditions.cabal --- a/cryptoconditions.cabal +++ b/cryptoconditions.cabal @@ -1,5 +1,5 @@ name: cryptoconditions -version: 0.2.3.0 +version: 0.2.4 synopsis: Interledger Crypto-Conditions description: Please see README.md homepage: https://github.com/libscott/cryptoconditions-hs diff --git a/test/TestUnits.hs b/test/TestUnits.hs --- a/test/TestUnits.hs +++ b/test/TestUnits.hs @@ -26,6 +26,8 @@ , [1] , [0, 1] , [2, 7] + , [15, 32] + , [155] ] test set = assertEqual "bit string equal" set (fromBitString $ toBitString set) in (\s -> testCase (show s) (test $ Set.fromList s)) <$> sets