diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Monadic GmbH + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Monadic GmbH nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +Haskell types describing [Content Identifiers](https://github.com/multiformats/cid) (CIDs). + +CIDs are "self-describing content-addressed identifiers" and are central to +addressing in [IPFS](https://ipfs.io), respectively [IPLD](https://ipld.io). diff --git a/ipld-cid.cabal b/ipld-cid.cabal new file mode 100644 --- /dev/null +++ b/ipld-cid.cabal @@ -0,0 +1,81 @@ +cabal-version: 2.2 +build-type: Simple + +name: ipld-cid +version: 0.1.0.0 +synopsis: IPLD Content-IDentifiers +homepage: https://github.com/oscoin/ipfs +bug-reports: https://github.com/oscoin/ipfs/issues +license: BSD-3-Clause +license-file: LICENSE +author: Kim Altintop +maintainer: Kim Altintop , Monadic Team +copyright: 2018 Monadic GmbH + +category: Data + +extra-source-files: + CHANGELOG.md + , README.md + +source-repository head + type: git + location: https://github.com/oscoin/ipfs + +common common + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fprint-expanded-synonyms + -funbox-small-strict-fields + default-extensions: + DeriveGeneric + LambdaCase + MultiWayIf + NamedFieldPuns + RecordWildCards + StrictData + TupleSections + +library + import: common + hs-source-dirs: src + exposed-modules: + Data.IPLD.CID + + build-depends: + base >= 4.9 && < 5 + , binary + , binary-varint + , bytestring + , cryptonite + , deepseq + , hashable + , multibase + , multihash-cryptonite + , text + +test-suite properties + import: common + main-is: Main.hs + hs-source-dirs: test/properties + type: exitcode-stdio-1.0 + + build-depends: + base + , bytestring + , cryptonite + , hedgehog + , ipld-cid + , multibase + , multihash-cryptonite + , text + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Data/IPLD/CID.hs b/src/Data/IPLD/CID.hs new file mode 100644 --- /dev/null +++ b/src/Data/IPLD/CID.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Copyright : 2018 Monadic GmbH +-- License : BSD3 +-- Maintainer : kim@monadic.xyz, team@monadic.xyz +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- +-- +-- \"CID is a format for referencing content in distributed information systems, +-- like IPFS. It leverages content addressing, cryptographic hashing, and +-- self-describing formats. It is the core identifier used by IPFS and IPLD.\" +module Data.IPLD.CID + ( Version (..) + , Codec (..) + + , CID + , cidVersion + , cidCodec + , cidHash + , newCidV0 + , newCidV1 + , buildCid + , decodeCid + , getCid + + , cidFromText + , cidToText + + , codecToCode + , codecFromCode + ) +where + +import Control.DeepSeq (NFData) +import Control.Monad ((>=>)) +import Crypto.Hash (Digest, SHA256) +import Data.Bifunctor (bimap) +import Data.Binary.Get as Binary +import Data.Binary.VarInt (buildVarInt, getVarInt) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.BaseN as BaseN +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Multibase as Multibase +import Data.Hashable (Hashable) +import Data.Multihash (Multihash, Multihashable) +import qualified Data.Multihash as Multihash +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Word (Word8) +import GHC.Generics (Generic) + +-- | Specification version. +data Version = V0 | V1 + deriving (Eq, Show, Ord, Enum, Bounded, Generic) + +instance Hashable Version +instance NFData Version + +-- | The content type or format of the data being addressed, specified as a +-- . +-- +-- Note that we do not currently have a full multicodec implementation, as it is +-- overly complicated for our purposes. We also only support 'Codec's on an +-- as-needed basis. Future versions may utilise a separate library. +data Codec + = Raw + | DagProtobuf + | DagCbor + | GitRaw + deriving (Eq, Show, Ord, Generic) + +instance Hashable Codec +instance NFData Codec + +-- | A Content IDentifier. +-- +-- * 'V0' 'CID's are merely SHA256 hashes, base58-encoded using the bitcoin +-- alphabet. The 'Codec' is implicitly 'DagProtobuf'. +-- * 'V1' 'CID's may use any 'Multihash', and any of the supported 'Codec's. +data CID = CID + { cidVersion :: Version + , cidCodec :: Codec + , cidHash :: Multihash + } deriving (Eq, Ord, Generic) + +instance Hashable CID +instance NFData CID + +instance Show CID where + show = Text.unpack . cidToText + +instance Read CID where + readsPrec _ = + either (const []) (\cid -> [(cid, "")]) . cidFromText . Text.pack + +-- CID ------------------------------------------------------------------------- + +-- | Create a 'V0' 'CID'. +newCidV0 :: Digest SHA256 -> CID +newCidV0 dig = CID + { cidVersion = V0 + , cidCodec = DagProtobuf + , cidHash = Multihash.fromDigest dig + } + +-- | Create a 'V1' 'CID'. +newCidV1 :: Multihashable a => Codec -> Digest a -> CID +newCidV1 codec dig = CID + { cidVersion = V1 + , cidCodec = codec + , cidHash = Multihash.fromDigest dig + } + +-- | Serialise a 'CID'. +buildCid :: CID -> Builder +buildCid CID{..} = case cidVersion of + V0 -> Builder.byteString (Multihash.encodedBytes cidHash) + V1 -> buildVarInt (fromEnum cidVersion) + <> buildVarInt (codecToCode cidCodec) + <> Builder.byteString (Multihash.encodedBytes cidHash) + +-- | Decode a 'CID' from a strict 'ByteString'. +-- +-- @ +-- decodeCid . buildCid ≡ Right +-- @ +decodeCid :: ByteString -> Either String CID +decodeCid bs + | isV0 = newCidV0 <$> Multihash.decodeDigest bs + | otherwise = bimap _3 _3 . Binary.runGetOrFail getCid $ LBS.fromStrict bs + where + isV0 = BS.length bs == 34 && magic == BS.take 2 bs + magic = BS.pack [18,32] + + _3 (_,_,x) = x + +-- | Deserialise a 'CID' in the 'Binary.Get' monad. +-- +-- Note that this does __/not/__ support 'V0' 'CID's. +getCid :: Binary.Get CID +getCid = do + cidVersion <- do + v <- Binary.getWord8 >>= getVarInt + if v < minVersion || v > maxVersion then + fail $ "CID: Invalid version: " <> show v + else + pure $ toEnum v + + case cidVersion of + V1 -> do + cidCodec <- do + c <- Binary.getWord8 >>= getVarInt + maybe (fail ("CID: Unknown Codec: " <> show c)) pure + $ codecFromCode c + cidHash <- Multihash.getMultihash + pure CID{..} + v -> fail $ "CID: Unsupported version: " <> show v + where + maxVersion = fromEnum (maxBound :: Version) + minVersion = fromEnum (minBound :: Version) + +-- | Decode a 'CID' from a textual representation. +-- +-- The 'Text' value is expected to be base58 (bitcoin) encoded (for 'V0' +-- 'CID's), or a valid 'Multibase'. +-- +-- @ +-- cidFromText . cidToText ≡ id +-- @ +cidFromText :: Text -> Either String CID +cidFromText t = decodeBase >=> decodeCid $ encodeUtf8 t + where + isV0 = Text.length t == 46 && "Qm" `Text.isPrefixOf` t + + decodeBase | isV0 = BaseN.decodeBase58btc + | otherwise = Multibase.decode >=> guardReserved + + -- "If the first decoded byte is 0x12, return an error. CIDv0 CIDs may not + -- be multibase encoded and there will be no CIDv18 (0x12 = 18) to prevent + -- ambiguity with decoded CIDv0s." + guardReserved bs = case BS.uncons bs of + Just (x, _) | x == 18 -> Left "CID > V0 starts with reserved byte 0x12" + _ -> Right bs + +-- | Encode a 'CID' to a textual representation. +-- +-- The result is either a base58 (bitcoin) encoded string of just the 'cidHash' +-- value for 'V0' 'CID's, or otherwise a 'Multibase' value at base 'Base58btc' +-- of the binary representation of the 'CID' (as produced by 'buildCid'). +cidToText :: CID -> Text +cidToText cid = + decodeUtf8 + $ case cidVersion cid of + V0 -> BaseN.encodedBytes + . BaseN.encodeBase58btc + . Multihash.encodedBytes + $ cidHash cid + V1 -> Multibase.fromMultibase + . Multibase.encode + . BaseN.encodeBase58btc + . LBS.toStrict . Builder.toLazyByteString + $ buildCid cid + +-- Codec ----------------------------------------------------------------------- + +-- | numerical code of +-- the given 'Codec'. +codecToCode :: Codec -> Word8 +codecToCode Raw = 0x55 +codecToCode DagProtobuf = 0x70 +codecToCode DagCbor = 0x71 +codecToCode GitRaw = 0x78 + +-- | Attempt to convert from a +-- numerical code to a 'Codec'. +codecFromCode :: Word8 -> Maybe Codec +codecFromCode 0x55 = pure Raw +codecFromCode 0x70 = pure DagProtobuf +codecFromCode 0x71 = pure DagCbor +codecFromCode 0x78 = pure GitRaw +codecFromCode _ = Nothing diff --git a/test/properties/Main.hs b/test/properties/Main.hs new file mode 100644 --- /dev/null +++ b/test/properties/Main.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.Monad (unless) +import qualified Crypto.Hash as C +import Data.ByteString (ByteString) +import qualified Data.ByteString.BaseN as BaseN +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (for_) +import Data.Functor.Identity (Identity) +import Data.List (isInfixOf) +import Data.Text.Encoding (decodeUtf8) +import System.Exit (exitFailure) +import System.IO (BufferMode(..), hSetBuffering, stderr, stdout) + +import Data.ByteString.Multibase (fromMultibase) +import qualified Data.ByteString.Multibase as Multibase +import Data.IPLD.CID + ( CID + , buildCid + , cidFromText + , cidToText + , newCidV0 + , newCidV1 + ) +import qualified Data.IPLD.CID as CID +import Data.Multihash (Multihash, Multihashable) +import qualified Data.Multihash as Multihash +import Data.Multihash.Internal (HashAlgorithm(..)) + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +main :: IO () +main = do + for_ [stdout, stderr] $ flip hSetBuffering LineBuffering + + ok <- props + unless ok exitFailure + +props :: IO Bool +props = checkParallel $$(discover) + +prop_roundtripBytes :: Property +prop_roundtripBytes = property $ do + cid <- forAll genCID + tripping cid (Builder.toLazyByteString . buildCid) (CID.decodeCid . LBS.toStrict) + +prop_roundtripText :: Property +prop_roundtripText = property $ do + cid <- forAll genCID + tripping cid cidToText cidFromText + +-- | "If the first decoded byte is 0x12, return an error. CIDv0 CIDs may not be +-- multibase encoded and there will be no CIDv18 (0x12 = 18) to prevent +-- ambiguity with decoded CIDv0s." +-- +-- It seems like the only way this can happen is to pass a 'C.SHA256' +-- 'Multihash' (or an arbitrary byte sequence which happens to start with 0x12), +-- encoded at some base /= 'Base58btc'. ie. the multibase encoding has to be +-- valid. +prop_ambiguousVersion :: Property +prop_ambiguousVersion = property $ do + hash <- forAllWith (show . Multihash.encodedBytes) (genMultihash C.SHA256) + let + encoded = Multibase.encode (BaseN.encodeAtBase BaseN.Base32 . Multihash.encodedBytes $ hash) + notACid = decodeUtf8 $ fromMultibase encoded + fromTxt = cidFromText notACid + in do + annotate (show $ fromMultibase encoded) + annotateShow notACid + annotateShow fromTxt + case fromTxt of + Left e | "reserved" `isInfixOf` e -> success + _ -> failure +-- Generators ------------------------------------------------------------------ + +genCID :: GenT Identity CID +genCID = Gen.choice [v0, v1] + where + v0 = newCidV0 <$> genDigest + v1 = do + codec <- genCodec + algo <- genHashAlgorithm + case algo of + Blake2s_160 -> newCidV1 codec <$> genDigest @C.Blake2s_160 + Blake2s_224 -> newCidV1 codec <$> genDigest @C.Blake2s_224 + Blake2s_256 -> newCidV1 codec <$> genDigest @C.Blake2s_256 + Blake2b_160 -> newCidV1 codec <$> genDigest @C.Blake2b_160 + Blake2b_224 -> newCidV1 codec <$> genDigest @C.Blake2b_224 + Blake2b_256 -> newCidV1 codec <$> genDigest @C.Blake2b_256 + Blake2b_384 -> newCidV1 codec <$> genDigest @C.Blake2b_384 + Blake2b_512 -> newCidV1 codec <$> genDigest @C.Blake2b_512 + MD4 -> newCidV1 codec <$> genDigest @C.MD4 + MD5 -> newCidV1 codec <$> genDigest @C.MD5 + SHA1 -> newCidV1 codec <$> genDigest @C.SHA1 + SHA256 -> newCidV1 codec <$> genDigest @C.SHA256 + SHA512 -> newCidV1 codec <$> genDigest @C.SHA512 + Keccak_224 -> newCidV1 codec <$> genDigest @C.Keccak_224 + Keccak_256 -> newCidV1 codec <$> genDigest @C.Keccak_256 + Keccak_384 -> newCidV1 codec <$> genDigest @C.Keccak_384 + Keccak_512 -> newCidV1 codec <$> genDigest @C.Keccak_512 + SHA3_224 -> newCidV1 codec <$> genDigest @C.SHA3_224 + SHA3_256 -> newCidV1 codec <$> genDigest @C.SHA3_256 + SHA3_384 -> newCidV1 codec <$> genDigest @C.SHA3_384 + SHA3_512 -> newCidV1 codec <$> genDigest @C.SHA3_512 + +genMultihash :: forall a. Multihashable a => a -> GenT Identity Multihash +genMultihash _ = Multihash.fromDigest <$> genDigest @a + +genDigest :: Multihashable a => GenT Identity (C.Digest a) +genDigest = C.hash <$> genBytes + +genHashAlgorithm :: GenT Identity Multihash.HashAlgorithm +genHashAlgorithm = Gen.prune Gen.enumBounded + +genBytes :: GenT Identity ByteString +genBytes = Gen.prune $ Gen.bytes (Range.singleton 255) + +genCodec :: GenT Identity CID.Codec +genCodec = Gen.element [CID.Raw, CID.DagProtobuf, CID.DagCbor, CID.GitRaw]