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,1 @@ +Haskell implementation of [multibase](https://github.com/multiformats/multibase): "self-identifying base encodings". diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/multibase.cabal b/multibase.cabal new file mode 100644 --- /dev/null +++ b/multibase.cabal @@ -0,0 +1,84 @@ +cabal-version: 2.2 +build-type: Custom + +name: multibase +version: 0.1.0.0 +synopsis: Self-identifying base encodings, implementation of +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 + +custom-setup + setup-depends: + base >= 4.9 && < 5 + , Cabal + , cabal-doctest >= 1 + +common common + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fprint-expanded-synonyms + -funbox-small-strict-fields + +library + import: common + hs-source-dirs: src + exposed-modules: + Data.ByteString.BaseN + Data.ByteString.Multibase + + build-depends: + , aeson + , base >= 4.9 && < 5 + , base16-bytestring + , base32-z-bytestring + , base58-bytestring + , base64-bytestring + , bytestring + , deepseq + , formatting + , hashable + , sandi + , serialise + , tagged + , text + +test-suite doctests + import: common + main-is: Main.hs + hs-source-dirs: test/doctests + type: exitcode-stdio-1.0 + + other-modules: Build_doctests + autogen-modules: Build_doctests + + build-depends: + base + , doctest + , multibase + , QuickCheck + , template-haskell + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Data/ByteString/BaseN.hs b/src/Data/ByteString/BaseN.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/BaseN.hs @@ -0,0 +1,992 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Copyright : 2019 Monadic GmbH +-- License : BSD3 +-- Maintainer : kim@monadic.xyz, alfredo@monadic.xyz, team@monadic.xyz +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Type-safe kitchen sink base-N encoding and decoding of strict 'ByteString's. +-- + +module Data.ByteString.BaseN + ( Base(..) + + , AtBase + , encodedBytes + , encodedBuilder + + , Base2 + , Base16 + , Base58 + , Base64 + , BaseIdentity + , Base16upper + , Base32hex + , Base32hexupper + , Base32hexpad + , Base32hexpadupper + , Base32 + , Base32z + , Base32upper + , Base32pad + , Base32padupper + , Base58flickr + , Base58btc + , Base64pad + , Base64url + , Base64urlpad + -- * Compact Representation + , AtBaseCompact + , compact + , expand + + -- * Tagged + -- $tagged + , Base16Of + , Base58Of + , Base64Of + + -- ** Re-exports + , tagWith + , unTagged + + -- ** CBOR + -- $cbor + , DeserialiseError(..) + , deserialiseAtBase + + -- * Encoding + -- $encoding + , encodeBase16 + , encodeBase58btc + , encodeBase64 + , encodeAtBase + + -- * Decoding Bytes + -- $decodingbytes + , DecodeBase + , decodeBase16 + , decodeBase16Either + , decodeBase58btc + , decodeBase64 + , decodeBase64Either + , decodeBase64Lenient + , decodeAtBase + , decodeAtBaseEither + + -- * Decoding + , decode + + -- ** Untrusted Input + -- $untrusted + , ValidBase + , validBase16 + , validBase16Either + , validBase58btc + , validBase58btcEither + , validBase64 + , validBase64Either + , validAtBase + , validAtBaseEither + + , validAndDecoded + , validAndDecodedEither + + -- * 'Text' + , encodedTextAtBase + , encodedText + , encodedTextBuilder + + -- * 'Formatting' + , format + , formatAtBase + ) where + +import Prelude + +import qualified Codec.Binary.Base32 as Base32 +import qualified Codec.Binary.Base32Hex as Base32Hex +import Codec.Serialise + ( DeserialiseFailure + , Serialise + , deserialiseOrFail + ) +import Control.DeepSeq (NFData) +import Data.Aeson + ( FromJSON(..) + , FromJSONKey + , ToJSON(..) + , ToJSONKey + , withText + ) +import qualified Data.Aeson.Encoding as JSON +import Data.Bifunctor (bimap, first, second) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base32.Z as Base32z +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base64.URL as Base64Url +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Builder +import Data.ByteString.Char8 (unpack) +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Lazy (fromStrict) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as Short +import Data.Char (toLower, toUpper) +import Data.Hashable (Hashable) +import Data.Proxy (Proxy(..)) +import Data.String (IsString(..)) +import Data.Tagged (Tagged, tagWith, unTagged) +import Data.Text (Text) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import qualified Data.Text.Lazy.Builder as T +import qualified Formatting +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Text.Show (Show(..), showParen, showString) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Test.QuickCheck +-- >>> import qualified Data.ByteString as BS +-- >>> newtype Bytes = Bytes ByteString deriving (Eq, Show) +-- >>> instance Arbitrary Bytes where arbitrary = Bytes . BS.pack <$> arbitrary + +-- | Supported bases. +data Base (a :: Symbol) where + BaseIdentity :: Base "id" + Base2 :: Base "2" + Base16 :: Base "16" + Base64 :: Base "64" + -- | hexadecimal, uppercase alphabet + Base16upper :: Base "16u" + -- | RFC4648 no padding - highest char + Base32hex :: Base "32x" + -- | RFC4648 no padding - highest char, uppercase alphabet + Base32hexupper :: Base "32xu" + -- | RFC4648 with padding + Base32hexpad :: Base "32xp" + -- | RFC4648 with padding, uppercase alphabet + Base32hexpadupper :: Base "32xpu" + -- | RFC4648 no padding + Base32 :: Base "32" + -- | z-base-32 (used by Tahoe-LAFS) + Base32z :: Base "32z" + -- | RFC4648 no padding, uppercase alphabet + Base32upper :: Base "32u" + -- | RFC4648 with padding + Base32pad :: Base "32p" + -- | RFC4648 with padding, uppercase alphabet + Base32padupper :: Base "32pu" + -- | base58 flickr alphabet + Base58flickr :: Base "58flickr" + -- | base58 bitcoint alphabet + Base58btc :: Base "58btc" + -- | RFC4648 with padding (MIME-encoding) + Base64pad :: Base "64p" + -- | RFC4648 no padding + Base64url :: Base "64url" + -- | RFC4648 with padding + Base64urlpad :: Base "64urlp" + +-- | A 'ByteString' encoded at a specific base. +newtype AtBase (b :: Symbol) = BaseN { fromAtBase :: ByteString } + deriving (Eq, Ord, NFData, Hashable) + +-- | Extract the base-n encoded bytes from an 'AtBase'. +-- +-- To recover the original 'ByteString' (*not* base-n encoded), use 'decode'. +encodedBytes :: AtBase b -> ByteString +encodedBytes (BaseN bs) = bs + +-- | Like 'encodedBytes', but return a 'Builder'. +encodedBuilder :: AtBase b -> Builder +encodedBuilder = Builder.byteString . encodedBytes + +instance KnownSymbol b => Show (AtBase b) where + showsPrec p (BaseN bs) = showParen (p >= 11) + ( showString ("Base" <> show (symbolVal (Proxy @b)) <> " ") + . showsPrec 11 bs + ) + +instance ValidBase b => IsString (AtBase b) where + fromString = either error id . validAtBaseEither (Proxy @b) . C8.pack + +instance ToJSON (AtBase b) where + toJSON = toJSON . encodedText + toEncoding = JSON.text . encodedText + +instance (ValidBase b, KnownSymbol b) => FromJSON (AtBase b) where + parseJSON = + withText ("AtBase " <> show (symbolVal (Proxy @b))) $ + either fail pure . validAtBaseEither (Proxy @b) . encodeUtf8 + +instance ToJSONKey (AtBase b) +instance (ValidBase b, KnownSymbol b) => FromJSONKey (AtBase b) + +type Base2 = AtBase "2" +type Base16 = AtBase "16" +type Base58 = AtBase "58" +type Base64 = AtBase "64" +type BaseIdentity = AtBase "id" +type Base16upper = AtBase "16u" +type Base32hex = AtBase "16x" +type Base32hexupper = AtBase "16xu" +type Base32hexpad = AtBase "16xp" +type Base32hexpadupper = AtBase "16xup" +type Base32 = AtBase "32" +type Base32z = AtBase "32z" +type Base32upper = AtBase "32u" +type Base32pad = AtBase "32p" +type Base32padupper = AtBase "32pu" +type Base58flickr = AtBase "58flickr" +type Base58btc = AtBase "58btc" +type Base64pad = AtBase "64p" +type Base64url = AtBase "64url" +type Base64urlpad = AtBase "16urlp" + +-- Compact --------------------------------------------------------------------- + +-- | A more memory-efficient representation of base-n encoded bytes. +-- +-- Uses 'ShortByteString', recommendations and caveats described there apply. +newtype AtBaseCompact (b :: Symbol) = BaseNShort + { fromAtBaseCompact :: ShortByteString + } deriving (Eq, Ord, Hashable, NFData) + +instance KnownSymbol b => Show (AtBaseCompact b) where + showsPrec p (BaseNShort bs) = showParen (p >= 11) + ( showString ("Base" <> show (symbolVal (Proxy @b)) <> "Compact ") + . showsPrec 11 bs + ) + +compact :: AtBase b -> AtBaseCompact b +compact = BaseNShort . Short.toShort . fromAtBase + +expand :: AtBaseCompact b -> AtBase b +expand = BaseN . Short.fromShort . fromAtBaseCompact + +-- $tagged +-- 'AtBase' values tagged by the type they're representing. + +type Base16Of a = Tagged a (AtBase "16") +type Base58Of a = Tagged a (AtBase "58") +type Base64Of a = Tagged a (AtBase "64") + +-- $cbor +-- Directly go from (presumed to be) base-n encoded 'ByteString' to +-- de-'Serialise'-able value. + +data DeserialiseError = + DecodeBaseError String + | DeserialiseError DeserialiseFailure + deriving Show + +deserialiseAtBase + :: ( Serialise a + , DecodeBase b + ) + => proxy b + -> ByteString + -> Either DeserialiseError a +deserialiseAtBase base bs = do + bs' <- bimap DecodeBaseError fromStrict $ decodeAtBaseEither base bs + first DeserialiseError $ deserialiseOrFail bs' + +-- $encoding + +encodeBase16 :: ByteString -> AtBase "16" +encodeBase16 = BaseN . Base16.encode +{-# INLINE encodeBase16 #-} + +encodeBase64 :: ByteString -> AtBase "64" +encodeBase64 = BaseN . Base64.encode +{-# INLINE encodeBase64 #-} + +-- | +-- >>> fromAtBase $ encodeBase16upper "hello world" +-- "68656C6C6F20776F726C64" +encodeBase16upper :: ByteString -> AtBase "16u" +encodeBase16upper = BaseN . C8.map toUpper . Base16.encode +{-# INLINE encodeBase16upper #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase16upper (fromAtBase $ encodeBase16upper bytes) === Right bytes +decodeBase16upper :: ByteString -> Either String ByteString +decodeBase16upper = decodeBase16Either +{-# INLINE decodeBase16upper #-} + +-- Base 32 --------------------------------------------------------------------- + +-- | +-- >>> fromAtBase . encodeBase32hex $ "hello world" +-- "d1imor3f41rmusjccg" +encodeBase32hex :: ByteString -> AtBase "32x" +encodeBase32hex = BaseN . C8.map toLower . dropPadding . Base32Hex.encode +{-# INLINE encodeBase32hex #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32hex (fromAtBase $ encodeBase32hex bytes) === Right bytes +decodeBase32hex :: ByteString -> Either String ByteString +decodeBase32hex bs + | C8.null bs = pure mempty + | otherwise = first (base32Err bs) . Base32Hex.decode . padTo 8 . C8.map toUpper $ bs +{-# INLINE decodeBase32hex #-} + +-- | +-- >>> fromAtBase . encodeBase32hexupper $ "hello world" +-- "D1IMOR3F41RMUSJCCG" +encodeBase32hexupper :: ByteString -> AtBase "32xu" +encodeBase32hexupper = BaseN . dropPadding . Base32Hex.encode +{-# INLINE encodeBase32hexupper #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32hexupper (fromAtBase $ encodeBase32hexupper bytes) === Right bytes +decodeBase32hexupper :: ByteString -> Either String ByteString +decodeBase32hexupper bs = first (base32Err bs) . Base32Hex.decode . padTo 8 $ bs +{-# INLINE decodeBase32hexupper #-} + +-- | +-- >>> fromAtBase . encodeBase32hexpad $ "hello world" +-- "d1imor3f41rmusjccg======" +encodeBase32hexpad :: ByteString -> AtBase "32xp" +encodeBase32hexpad = BaseN . C8.map toLower . Base32Hex.encode +{-# INLINE encodeBase32hexpad #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32hexpad (fromAtBase $ encodeBase32hexpad bytes) === Right bytes +decodeBase32hexpad :: ByteString -> Either String ByteString +decodeBase32hexpad bs = + first (base32Err bs) . Base32Hex.decode . C8.map toUpper $ bs +{-# INLINE decodeBase32hexpad #-} + +-- | +-- >>> fromAtBase . encodeBase32hexpadupper $ "hello world" +-- "D1IMOR3F41RMUSJCCG======" +encodeBase32hexpadupper :: ByteString -> AtBase "32xpu" +encodeBase32hexpadupper = BaseN . Base32Hex.encode +{-# INLINE encodeBase32hexpadupper #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32hexpadupper (fromAtBase $ encodeBase32hexpadupper bytes) === Right bytes +decodeBase32hexpadupper :: ByteString -> Either String ByteString +decodeBase32hexpadupper bs = first (base32Err bs) . Base32Hex.decode $ bs +{-# INLINE decodeBase32hexpadupper #-} + +-- | +-- >>> fromAtBase . encodeBase32 $ "hello world" +-- "nbswy3dpeb3w64tmmq" +encodeBase32 :: ByteString -> AtBase "32" +encodeBase32 = BaseN . C8.map toLower . dropPadding . Base32.encode +{-# INLINE encodeBase32 #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32 (fromAtBase $ encodeBase32 bytes) === Right bytes +decodeBase32 :: ByteString -> Either String ByteString +decodeBase32 bs = + first (base32Err bs) . Base32.decode . padTo 8 . C8.map toUpper $ bs +{-# INLINE decodeBase32 #-} + +-- | +-- >>> fromAtBase . encodeBase32z $ "hello world" +-- "pb1sa5dxrb5s6hucco" +encodeBase32z :: ByteString -> AtBase "32z" +encodeBase32z = BaseN . Base32z.encode +{-# INLINE encodeBase32z #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32z (fromAtBase $ encodeBase32z bytes) === Right bytes +decodeBase32z :: ByteString -> Either String ByteString +decodeBase32z = Base32z.decode . C8.map toLower +{-# INLINE decodeBase32z #-} +-- | +-- >>> fromAtBase . encodeBase32upper $ "hello world" +-- "NBSWY3DPEB3W64TMMQ" +encodeBase32upper :: ByteString -> AtBase "32u" +encodeBase32upper = BaseN . dropPadding . Base32.encode +{-# INLINE encodeBase32upper #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32upper (fromAtBase $ encodeBase32upper bytes) === Right bytes +decodeBase32upper :: ByteString -> Either String ByteString +decodeBase32upper bs = first (base32Err bs) . Base32.decode . padTo 8 $ bs +{-# INLINE decodeBase32upper #-} + +-- | +-- >>> fromAtBase . encodeBase32pad $ "hello world" +-- "nbswy3dpeb3w64tmmq======" +encodeBase32pad :: ByteString -> AtBase "32p" +encodeBase32pad = BaseN . C8.map toLower . Base32.encode +{-# INLINE encodeBase32pad #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32pad (fromAtBase $ encodeBase32pad bytes) === Right bytes +decodeBase32pad :: ByteString -> Either String ByteString +decodeBase32pad bs = first (base32Err bs) . Base32.decode . C8.map toUpper $ bs +{-# INLINE decodeBase32pad #-} + +-- | +-- >>> fromAtBase . encodeBase32padupper $ "hello world" +-- "NBSWY3DPEB3W64TMMQ======" +encodeBase32padupper :: ByteString -> AtBase "32pu" +encodeBase32padupper = BaseN . Base32.encode +{-# INLINE encodeBase32padupper #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase32padupper (fromAtBase $ encodeBase32padupper bytes) === Right bytes +decodeBase32padupper :: ByteString -> Either String ByteString +decodeBase32padupper bs = first (base32Err bs) . Base32.decode $ bs +{-# INLINE decodeBase32padupper #-} + +base32Err :: ByteString -> (ByteString, ByteString) -> String +base32Err orig (x, invalid) = mconcat + [ "Decoded " + , "`", unpack orig, "`" + , " to " + , "`", unpack x, "`" + , " until invalid sequence: " + , "`", unpack invalid, "`" + ] + +-- Base 58 --------------------------------------------------------------------- + +-- | +-- >>> fromAtBase . encodeBase58flickr $ "hello world" +-- "rTu1dk6cWsRYjYu" +encodeBase58flickr :: ByteString -> AtBase "58flickr" +encodeBase58flickr = BaseN . Base58.encodeBase58 Base58.flickrAlphabet +{-# INLINE encodeBase58flickr #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase58flickr (fromAtBase $ encodeBase58flickr bytes) === Right bytes +decodeBase58flickr :: ByteString -> Either String ByteString +decodeBase58flickr = + note "Invalid characters in Base58flickr string" + . Base58.decodeBase58 Base58.flickrAlphabet +{-# INLINE decodeBase58flickr #-} + +-- | +-- >>> fromAtBase . encodeBase58btc $ "hello world" +-- "StV1DL6CwTryKyV" +encodeBase58btc :: ByteString -> AtBase "58btc" +encodeBase58btc = BaseN . Base58.encodeBase58 Base58.bitcoinAlphabet +{-# INLINE encodeBase58btc #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase58btc (fromAtBase $ encodeBase58btc bytes) === Right bytes +decodeBase58btc :: ByteString -> Either String ByteString +decodeBase58btc = + note "Invalid characters in Base58btc string" + . Base58.decodeBase58 Base58.bitcoinAlphabet +{-# INLINE decodeBase58btc #-} + +-- | +-- >>> fromAtBase . encodeBase64pad $ "hello world" +-- "aGVsbG8gd29ybGQ=" +encodeBase64pad :: ByteString -> AtBase "64p" +encodeBase64pad = BaseN . Base64.encode +{-# INLINE encodeBase64pad #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase64pad (fromAtBase $ encodeBase64pad bytes) === Right bytes +decodeBase64pad :: ByteString -> Either String ByteString +decodeBase64pad = Base64.decode +{-# INLINE decodeBase64pad #-} + +-- | +-- >>> fromAtBase . encodeBase64url $ "hello world" +-- "aGVsbG8gd29ybGQ" +encodeBase64url :: ByteString -> AtBase "64url" +encodeBase64url = BaseN . fst . C8.spanEnd (== '=') . Base64Url.encode +{-# INLINE encodeBase64url #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase64url (fromAtBase $ encodeBase64url bytes) === Right bytes +decodeBase64url :: ByteString -> Either String ByteString +decodeBase64url = Base64Url.decode . padTo 4 +{-# INLINE decodeBase64url #-} + +-- | +-- >>> fromAtBase . encodeBase64urlpad $ "hello world" +-- "aGVsbG8gd29ybGQ=" +encodeBase64urlpad :: ByteString -> AtBase "64urlp" +encodeBase64urlpad = BaseN . Base64Url.encode +{-# INLINE encodeBase64urlpad #-} + +-- | +-- prop> \(Bytes bytes) -> decodeBase64urlpad (fromAtBase $ encodeBase64urlpad bytes) === Right bytes +decodeBase64urlpad :: ByteString -> Either String ByteString +decodeBase64urlpad = Base64Url.decode +{-# INLINE decodeBase64urlpad #-} + +-- | Encode at a base supplied at runtime. +encodeAtBase :: Base b -> ByteString -> AtBase b +encodeAtBase Base2 = BaseN +encodeAtBase Base16 = encodeBase16 +encodeAtBase Base64 = encodeBase64 +encodeAtBase BaseIdentity = BaseN +encodeAtBase Base16upper = encodeBase16upper +encodeAtBase Base32hex = encodeBase32hex +encodeAtBase Base32hexupper = encodeBase32hexupper +encodeAtBase Base32hexpad = encodeBase32hexpad +encodeAtBase Base32hexpadupper = encodeBase32hexpadupper +encodeAtBase Base32 = encodeBase32 +encodeAtBase Base32z = encodeBase32z +encodeAtBase Base32upper = encodeBase32upper +encodeAtBase Base32pad = encodeBase32pad +encodeAtBase Base32padupper = encodeBase32padupper +encodeAtBase Base58flickr = encodeBase58flickr +encodeAtBase Base58btc = encodeBase58btc +encodeAtBase Base64pad = encodeBase64pad +encodeAtBase Base64url = encodeBase64url +encodeAtBase Base64urlpad = encodeBase64urlpad + +-- $decodingbytes +-- Decode (presumed to be) base-n encoded 'ByteString's to their original +-- (base-2) value. + +decodeBase16 :: ByteString -> Maybe ByteString +decodeBase16 = either (const Nothing) pure . decodeBase16Either + +decodeBase16Either :: ByteString -> Either String ByteString +decodeBase16Either bs = + case Base16.decode bs of + (x, "") -> Right x + (x, invalid) -> Left . mconcat $ + [ "Decoded: " + , "`", unpack x, "`" + , " until invalid sequence: " + , "`", unpack invalid, "`" + ] +{-# INLINE decodeBase16Either #-} + +decodeBase64 :: ByteString -> Maybe ByteString +decodeBase64 = either (const Nothing) pure . decodeBase64Either + +decodeBase64Either :: ByteString -> Either String ByteString +decodeBase64Either = Base64.decode +{-# INLINE decodeBase64Either #-} + +decodeBase64Lenient :: ByteString -> ByteString +decodeBase64Lenient = Base64.decodeLenient +{-# INLINE decodeBase64Lenient #-} + +class DecodeBase (b :: Symbol) where + decodeAtBase :: proxy b -> ByteString -> Maybe ByteString + decodeAtBaseEither :: proxy b -> ByteString -> Either String ByteString + +instance DecodeBase "id" where + decodeAtBase = const pure + decodeAtBaseEither = const pure + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "2" where + decodeAtBase = const pure + decodeAtBaseEither = const pure + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "16" where + decodeAtBase = const decodeBase16 + decodeAtBaseEither = const decodeBase16Either + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "16u" where + decodeAtBase = const (hush . decodeBase16upper) + decodeAtBaseEither = const decodeBase16upper + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32" where + decodeAtBase = const (hush . decodeBase32) + decodeAtBaseEither = const decodeBase32 + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32z" where + decodeAtBase = const (hush . decodeBase32z) + decodeAtBaseEither = const decodeBase32z + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32u" where + decodeAtBase = const (hush . decodeBase32upper) + decodeAtBaseEither = const decodeBase32upper + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32p" where + decodeAtBase = const (hush . decodeBase32pad) + decodeAtBaseEither = const decodeBase32pad + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32pu" where + decodeAtBase = const (hush . decodeBase32padupper) + decodeAtBaseEither = const decodeBase32padupper + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32x" where + decodeAtBase = const (hush . decodeBase32hex) + decodeAtBaseEither = const decodeBase32hex + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32xu" where + decodeAtBase = const (hush . decodeBase32hexupper) + decodeAtBaseEither = const decodeBase32hexupper + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32xp" where + decodeAtBase = const (hush . decodeBase32hexpad) + decodeAtBaseEither = const decodeBase32hexpad + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "32xpu" where + decodeAtBase = const (hush . decodeBase32hexpadupper) + decodeAtBaseEither = const decodeBase32hexpadupper + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "58btc" where + decodeAtBase = const (hush . decodeBase58btc) + decodeAtBaseEither = const decodeBase58btc + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "58flickr" where + decodeAtBase = const (hush . decodeBase58flickr) + decodeAtBaseEither = const decodeBase58flickr + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "64" where + decodeAtBase = const decodeBase64 + decodeAtBaseEither = const decodeBase64Either + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "64p" where + decodeAtBase = const (hush . decodeBase64pad) + decodeAtBaseEither = const decodeBase64pad + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "64url" where + decodeAtBase = const (hush . decodeBase64url) + decodeAtBaseEither = const decodeBase64url + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +instance DecodeBase "64urlpad" where + decodeAtBase = const (hush . decodeBase64urlpad) + decodeAtBaseEither = const decodeBase64urlpad + {-# INLINE decodeAtBase #-} + {-# INLINE decodeAtBaseEither #-} + +-- | Recover the original 'ByteString' of a base-n encoded value. +decode :: DecodeBase b => AtBase b -> ByteString +decode at = case decodeAtBaseEither at (encodedBytes at) of + Left e -> error $ "Impossible: invalid base encoding: " <> e + Right b -> b + +-- $untrusted +-- Construct 'AtBase's from raw 'ByteString's. Note that this attempts to decode +-- using the functions from $decoding, and throws away the result. + +validBase16 :: ByteString -> Maybe (AtBase "16") +validBase16 bs = BaseN bs <$ decodeBase16 bs + +validBase16Either :: ByteString -> Either String (AtBase "16") +validBase16Either bs = second (const $ BaseN bs) $ decodeBase16Either bs + +validBase16upper :: ByteString -> Maybe (AtBase "16u") +validBase16upper bs = BaseN bs <$ hush (decodeBase16upper bs) + +validBase16upperEither :: ByteString -> Either String (AtBase "16u") +validBase16upperEither bs = second (const $ BaseN bs) $ decodeBase16upper bs + +validBase32hex :: ByteString -> Maybe (AtBase "32x") +validBase32hex bs = BaseN bs <$ hush (decodeBase32hex bs) + +validBase32hexEither :: ByteString -> Either String (AtBase "32x") +validBase32hexEither bs = second (const $ BaseN bs) $ decodeBase32hex bs + +validBase32hexupper :: ByteString -> Maybe (AtBase "32xu") +validBase32hexupper bs = BaseN bs <$ hush (decodeBase32hexupper bs) + +validBase32hexupperEither :: ByteString -> Either String (AtBase "32xu") +validBase32hexupperEither bs = second (const $ BaseN bs) $ decodeBase32hexupper bs + +validBase32hexpad :: ByteString -> Maybe (AtBase "32xp") +validBase32hexpad bs = BaseN bs <$ hush (decodeBase32hexpad bs) + +validBase32hexpadEither :: ByteString -> Either String (AtBase "32xp") +validBase32hexpadEither bs = second (const $ BaseN bs) $ decodeBase32hexpad bs + +validBase32hexpadupper :: ByteString -> Maybe (AtBase "32xpu") +validBase32hexpadupper bs = BaseN bs <$ hush (decodeBase32hexpadupper bs) + +validBase32hexpadupperEither :: ByteString -> Either String (AtBase "32xpu") +validBase32hexpadupperEither bs = second (const $ BaseN bs) $ decodeBase32hexpadupper bs + +validBase32 :: ByteString -> Maybe (AtBase "32") +validBase32 bs = BaseN bs <$ hush (decodeBase32 bs) + +validBase32Either :: ByteString -> Either String (AtBase "32") +validBase32Either bs = second (const $ BaseN bs) $ decodeBase32 bs + +validBase32z :: ByteString -> Maybe (AtBase "32z") +validBase32z bs = BaseN bs <$ hush (decodeBase32z bs) + +validBase32zEither :: ByteString -> Either String (AtBase "32z") +validBase32zEither bs = second (const $ BaseN bs) $ decodeBase32z bs + +validBase32upper :: ByteString -> Maybe (AtBase "32u") +validBase32upper bs = BaseN bs <$ hush (decodeBase32upper bs) + +validBase32upperEither :: ByteString -> Either String (AtBase "32u") +validBase32upperEither bs = second (const $ BaseN bs) $ decodeBase32upper bs + +validBase32pad :: ByteString -> Maybe (AtBase "32p") +validBase32pad bs = BaseN bs <$ hush (decodeBase32pad bs) + +validBase32padEither :: ByteString -> Either String (AtBase "32p") +validBase32padEither bs = second (const $ BaseN bs) $ decodeBase32pad bs + +validBase32padupper :: ByteString -> Maybe (AtBase "32pu") +validBase32padupper bs = BaseN bs <$ hush (decodeBase32padupper bs) + +validBase32padupperEither :: ByteString -> Either String (AtBase "32pu") +validBase32padupperEither bs = second (const $ BaseN bs) $ decodeBase32padupper bs + +validBase58btc :: ByteString -> Maybe (AtBase "58btc") +validBase58btc bs = BaseN bs <$ hush (decodeBase58btc bs) + +validBase58btcEither :: ByteString -> Either String (AtBase "58btc") +validBase58btcEither bs = second (const $ BaseN bs) $ decodeBase58btc bs + +validBase58flickr :: ByteString -> Maybe (AtBase "58flickr") +validBase58flickr bs = BaseN bs <$ hush (decodeBase58flickr bs) + +validBase58flickrEither :: ByteString -> Either String (AtBase "58flickr") +validBase58flickrEither bs = second (const $ BaseN bs) $ decodeBase58flickr bs + +validBase64 :: ByteString -> Maybe (AtBase "64") +validBase64 bs = BaseN bs <$ decodeBase64 bs + +validBase64Either :: ByteString -> Either String (AtBase "64") +validBase64Either bs = second (const $ BaseN bs) $ decodeBase64Either bs + +validBase64pad :: ByteString -> Maybe (AtBase "64p") +validBase64pad bs = BaseN bs <$ hush (decodeBase64pad bs) + +validBase64padEither :: ByteString -> Either String (AtBase "64p") +validBase64padEither bs = second (const $ BaseN bs) $ decodeBase64pad bs + +validBase64url :: ByteString -> Maybe (AtBase "64url") +validBase64url bs = BaseN bs <$ hush (decodeBase64url bs) + +validBase64urlEither :: ByteString -> Either String (AtBase "64url") +validBase64urlEither bs = second (const $ BaseN bs) $ decodeBase64url bs + +validBase64urlpad :: ByteString -> Maybe (AtBase "64urlpad") +validBase64urlpad bs = BaseN bs <$ hush (decodeBase64urlpad bs) + +validBase64urlpadEither :: ByteString -> Either String (AtBase "64urlpad") +validBase64urlpadEither bs = second (const $ BaseN bs) $ decodeBase64urlpad bs + +class KnownSymbol b => ValidBase (b :: Symbol) where + validAtBase :: proxy b -> ByteString -> Maybe (AtBase b) + validAtBaseEither :: proxy b -> ByteString -> Either String (AtBase b) + +instance ValidBase "id" where + validAtBase = const (pure . BaseN) + validAtBaseEither = const (pure . BaseN) + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "2" where + validAtBase = const (pure . BaseN) + validAtBaseEither = const (pure . BaseN) + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "16" where + validAtBase = const validBase16 + validAtBaseEither = const validBase16Either + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "16u" where + validAtBase = const validBase16upper + validAtBaseEither = const validBase16upperEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32x" where + validAtBase = const validBase32hex + validAtBaseEither = const validBase32hexEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32xu" where + validAtBase = const validBase32hexupper + validAtBaseEither = const validBase32hexupperEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32xp" where + validAtBase = const validBase32hexpad + validAtBaseEither = const validBase32hexpadEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32xpu" where + validAtBase = const validBase32hexpadupper + validAtBaseEither = const validBase32hexpadupperEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32" where + validAtBase = const validBase32 + validAtBaseEither = const validBase32Either + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32z" where + validAtBase = const validBase32z + validAtBaseEither = const validBase32zEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32u" where + validAtBase = const validBase32upper + validAtBaseEither = const validBase32upperEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32p" where + validAtBase = const validBase32pad + validAtBaseEither = const validBase32padEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "32pu" where + validAtBase = const validBase32padupper + validAtBaseEither = const validBase32padupperEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "58btc" where + validAtBase = const validBase58btc + validAtBaseEither = const validBase58btcEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "58flickr" where + validAtBase = const validBase58flickr + validAtBaseEither = const validBase58flickrEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "64" where + validAtBase = const validBase64 + validAtBaseEither = const validBase64Either + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "64p" where + validAtBase = const validBase64pad + validAtBaseEither = const validBase64padEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "64url" where + validAtBase = const validBase64url + validAtBaseEither = const validBase64urlEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +instance ValidBase "64urlpad" where + validAtBase = const validBase64urlpad + validAtBaseEither = const validBase64urlpadEither + {-# INLINE validAtBase #-} + {-# INLINE validAtBaseEither #-} + +-- | Like 'validAtBase', but also return the decoded 'ByteString'. +validAndDecoded + :: DecodeBase b + => proxy b + -> ByteString + -> Maybe (AtBase b, ByteString) +validAndDecoded at bs = (BaseN bs,) <$> decodeAtBase at bs + +-- | Like 'validAtBaseEither', but also return the decoded 'ByteString'. +validAndDecodedEither + :: DecodeBase b + => proxy b + -> ByteString + -> Either String (AtBase b, ByteString) +validAndDecodedEither at bs = (BaseN bs,) <$> decodeAtBaseEither at bs + +-- Text ------------------------------------------------------------------------ + +-- | Like 'encodeAtBase', but from a 'Text' value. +encodedTextAtBase :: Base b -> Text -> AtBase b +encodedTextAtBase b = encodeAtBase b . encodeUtf8 +{-# INLINE encodedTextAtBase #-} + +-- | Like 'encodedBytes', but returns a 'Text' value. +encodedText :: AtBase b -> Text +encodedText (BaseN bs) = decodeLatin1 bs +{-# INLINE encodedText #-} + +-- | Like 'encodedBuilder', but returns a text 'T.Builder'. +encodedTextBuilder :: AtBase b -> T.Builder +encodedTextBuilder = T.fromText . encodedText +{-# INLINE encodedTextBuilder #-} + +-- Formatting ------------------------------------------------------------------ + +-- | Format a base-n encoded value. +format, formatAtBase :: Formatting.Format r (AtBase b -> r) +format = Formatting.later encodedTextBuilder + +formatAtBase = format +{-# INLINE formatAtBase #-} + +-- Helpers --------------------------------------------------------------------- + +dropPadding :: ByteString -> ByteString +dropPadding = fst . C8.spanEnd (== '=') +{-# INLINE dropPadding #-} + +padTo :: Int -> ByteString -> ByteString +padTo multipleof bs = + case C8.length bs `mod` multipleof of + 0 -> bs + x -> mappend bs (C8.replicate (multipleof - x) '=') + +note :: a -> Maybe b -> Either a b +note a = maybe (Left a) pure + +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just diff --git a/src/Data/ByteString/Multibase.hs b/src/Data/ByteString/Multibase.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Multibase.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Copyright : 2019 Monadic GmbH +-- License : BSD3 +-- Maintainer : kim@monadic.xyz, alfredo@monadic.xyz, team@monadic.xyz +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- encoding of strict 'ByteString's. +-- + +module Data.ByteString.Multibase + ( -- * Supported bases + BaseN.Base(..) + -- * Multibase encoding and decoding + , Multibase + , fromMultibase + , encodedBytes + , encode + , decode + + -- * Compact represenation + , CompactMultibase + , compact + , expand + ) +where + +import Control.DeepSeq (NFData) +import Data.ByteString (ByteString) +import Data.ByteString.BaseN (AtBase, ValidBase) +import qualified Data.ByteString.BaseN as BaseN +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Coerce (coerce) +import Data.Hashable (Hashable) +import Data.Typeable + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Test.QuickCheck +-- >>> import qualified Data.ByteString as BS +-- >>> newtype Bytes = Bytes ByteString deriving (Eq, Show) +-- >>> instance Arbitrary Bytes where arbitrary = Bytes . BS.pack <$> arbitrary + + +-- Bases we don't support yet +-- Base1 -- ^ unary (11111) ----- WTF? +-- | Base2 -- ^ binary (01010101) +-- | Base8 -- ^ octal +-- | Base10 -- ^ decimal + +class ValidBase b => ToCode b where + toCode :: proxy b -> Char + +instance ToCode "id" where + toCode = const '\000' +instance ToCode "16" where + toCode = const 'f' +instance ToCode "16u" where + toCode = const 'F' +instance ToCode "32x" where + toCode = const 'v' +instance ToCode "32xu" where + toCode = const 'V' +instance ToCode "32xp" where + toCode = const 't' +instance ToCode "32xpu" where + toCode = const 'T' +instance ToCode "32" where + toCode = const 'b' +instance ToCode "32z" where + toCode = const 'h' +instance ToCode "32u" where + toCode = const 'B' +instance ToCode "32p" where + toCode = const 'c' +instance ToCode "32pu" where + toCode = const 'C' +instance ToCode "58flickr" where + toCode = const 'Z' +instance ToCode "58btc" where + toCode = const 'z' +instance ToCode "64" where + toCode = const 'm' +instance ToCode "64p" where + toCode = const 'M' +instance ToCode "64url" where + toCode = const 'u' +instance ToCode "64urlpad" where + toCode = const 'U' + +-- codes we don't support yet +--toCode Base2 = '0' +--toCode Base8 = '7' +--toCode Base10 = '9' + +fromCode :: Char -> Maybe (ByteString -> Either String ByteString) +fromCode '\000' = pure pure -- 2 times pure, 2 times better! +fromCode 'f' = pure (BaseN.decodeAtBaseEither (Proxy @"16")) +fromCode 'F' = pure (BaseN.decodeAtBaseEither (Proxy @"16u")) +fromCode 'v' = pure (BaseN.decodeAtBaseEither (Proxy @"32x")) +fromCode 'V' = pure (BaseN.decodeAtBaseEither (Proxy @"32xu")) +fromCode 't' = pure (BaseN.decodeAtBaseEither (Proxy @"32xp")) +fromCode 'T' = pure (BaseN.decodeAtBaseEither (Proxy @"32xpu")) +fromCode 'b' = pure (BaseN.decodeAtBaseEither (Proxy @"32")) +fromCode 'h' = pure (BaseN.decodeAtBaseEither (Proxy @"32z")) +fromCode 'B' = pure (BaseN.decodeAtBaseEither (Proxy @"32u")) +fromCode 'c' = pure (BaseN.decodeAtBaseEither (Proxy @"32p")) +fromCode 'C' = pure (BaseN.decodeAtBaseEither (Proxy @"32pu")) +fromCode 'Z' = pure (BaseN.decodeAtBaseEither (Proxy @"58flickr")) +fromCode 'z' = pure (BaseN.decodeAtBaseEither (Proxy @"58btc")) +fromCode 'm' = pure (BaseN.decodeAtBaseEither (Proxy @"64")) +fromCode 'M' = pure (BaseN.decodeAtBaseEither (Proxy @"64p")) +fromCode 'u' = pure (BaseN.decodeAtBaseEither (Proxy @"64url")) +fromCode 'U' = pure (BaseN.decodeAtBaseEither (Proxy @"64urlpad")) +fromCode _ = Nothing + +-- | A multibase-encoded strict 'ByteString'. +newtype Multibase = Multibase ByteString + deriving (Eq, Ord, Hashable, NFData) + +-- | A 'Multibase backed by a 'ShortByteString'. +-- +-- This is useful when holding many 'Multibase' values in memory, due to lower +-- memory overhead and less heap fragmentation. See the documentation for +-- 'ShortByteString' for details. +newtype CompactMultibase = Compact ShortByteString + deriving (Eq, Ord, Hashable, NFData) + +-- | Extract the encoded bytes, including the code 'Char', from a 'Multibase'. +fromMultibase :: Multibase -> ByteString +fromMultibase = coerce + +-- | Extract the encoded bytes from a 'Multibase'. +-- +-- The code 'Char' signifying the base is stripped. +encodedBytes :: Multibase -> ByteString +encodedBytes = C8.tail . coerce + +-- | Encode a strict 'ByteString' at 'Base'. +encode :: ToCode b => AtBase b -> Multibase +encode base = coerce . C8.cons (toCode base) . BaseN.encodedBytes $ base + +-- | Decode a strict 'ByteString', assumed to be 'Multibase'-encoded. +decode :: ByteString -> Either String ByteString +decode bs = do + (c, bs') <- note "Empty input" $ C8.uncons bs + case fromCode c of + Just decodeIt -> decodeIt bs' + Nothing -> Left $ "Unknown encoding " <> show c + +-- | /O(n)/. Convert a 'Multibase' encoding to a compact representation. +-- +-- Involves copying the underlying 'ByteString'. +compact :: Multibase -> CompactMultibase +compact = coerce . toShort . coerce +{-# INLINE compact #-} + +-- | /O(n)/. Convert from the compact to the regular representation. +-- +-- Involves copying the underlying 'ShortByteString'. +expand :: CompactMultibase -> Multibase +expand = coerce . fromShort . coerce +{-# INLINE expand #-} + +-- Helpers --------------------------------------------------------------------- + +note :: a -> Maybe b -> Either a b +note a = maybe (Left a) pure diff --git a/test/doctests/Main.hs b/test/doctests/Main.hs new file mode 100644 --- /dev/null +++ b/test/doctests/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Build_doctests (flags, module_sources, pkgs) +import Test.DocTest (doctest) + +main :: IO () +main = doctest $ flags <> pkgs <> module_sources