diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015-2018, Futurice + +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 Oleg Grenrus 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,5 @@ +# haskell-base64-bytestring-type + +[![Build Status](https://travis-ci.org/futurice/haskell-base64-bytestring-type.svg?branch=master)](https://travis-ci.org/futurice/haskell-base64-bytestring-type) + +A 'ByteString64' -type with `FromJSON`, `ToJSON`, `Binary` and `Serializable` instances. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/base64-bytestring-type.cabal b/base64-bytestring-type.cabal new file mode 100644 --- /dev/null +++ b/base64-bytestring-type.cabal @@ -0,0 +1,88 @@ +name: base64-bytestring-type +version: 1 +synopsis: A newtype around ByteString, for base64 encoding +description: + A newtype around ByteString, for base64 encoding. + Strict and lazy, normal and url alphabet variants. +category: Web +homepage: https://github.com/futurice/haskell-base64-bytestring-type#readme +bug-reports: https://github.com/futurice/haskell-base64-bytestring-type/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: 1.12 +tested-with: + GHC==7.4.2, + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.1 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/futurice/haskell-base64-bytestring-type + +library + hs-source-dirs: + src + ghc-options: -Wall + + -- boot libraries + -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/VersionHistory + build-depends: + base >=4.5.1.0 && <4.11 + , binary >=0.5.1.0 && <0.10 + , bytestring >=0.9.2.1 && <0.11 + , deepseq >=1.3.0.0 && <1.5 + , text >=1.2.3.0 && <1.3 + + -- other dependencies: + build-depends: + aeson >=1.2.3.0 && <1.3 + , base-compat >=0.9.3 && <0.10 + , base64-bytestring >=1.0.0.1 && <1.1 + , cereal >=0.5.5.0 && <0.6 + , hashable >=1.2.6.1 && <1.3 + , QuickCheck >=2.11.3 && <2.12 + + if !impl(ghc >= 8.0) + build-depends: semigroups >=0.18.4 && <0.19 + + if impl(ghc < 7.5) + build-depends: ghc-prim + + exposed-modules: + Data.ByteString.Base64.Type + Data.ByteString.Base64.Lazy.Type + Data.ByteString.Base64.URL.Type + Data.ByteString.Base64.URL.Lazy.Type + default-language: Haskell2010 + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: + test + ghc-options: -Wall + + -- dependencies with bounds inherited from library: + build-depends: + base + , aeson + , binary + , bytestring + , base64-bytestring-type + , cereal + + -- other dependencies + build-depends: + tasty >=0.10.0.2 && <1.1 + , tasty-quickcheck >=0.8.3.2 && <0.10 diff --git a/src/Data/ByteString/Base64/Lazy/Type.hs b/src/Data/ByteString/Base64/Lazy/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/Lazy/Type.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Lazy 'ByteString' standard base64 encoding. +-- +-- See . +module Data.ByteString.Base64.Lazy.Type ( + ByteString64, + makeByteString64, + getByteString64, + mkBS64, + getBS64, + getEncodedByteString64, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq (NFData (..)) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText) +import Data.Aeson.Types (FromJSONKeyFunction (..), toJSONKeyText) +import Data.Binary (Binary (..)) +import Data.ByteString.Lazy (ByteString, pack, unpack) +import Data.Data (Data, Typeable) +import Data.Hashable (Hashable) +import Data.Semigroup (Semigroup (..)) +import Data.Serialize (Serialize) +import Data.String (IsString (..)) +import Data.Text.Lazy (fromStrict, toStrict) +import Data.Text.Lazy.Encoding (decodeLatin1, encodeUtf8) +import GHC.Generics (Generic) +import Test.QuickCheck + (Arbitrary (..), CoArbitrary (..), Function (..), functionMap, + shrinkMap) + +import qualified Data.ByteString.Base64.Lazy as Base64 + +#if !(MIN_VERSION_bytestring(0,10,0)) +import Data.ByteString.Lazy.Internal (ByteString (..)) +#endif + +-- | Aeson serialisable bytestring. Uses base64 encoding. +-- +-- The inner 'ByteString' is in raw format. +-- +-- >>> let bs64 = makeByteString64 "foobar" +-- >>> bs64 +-- mkBS64 "foobar" +-- +-- 'Binary' instance doesn't use base64 encoding: +-- +-- >>> Binary.encode bs64 +-- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ACKfoobar" +-- +-- 'Aeson' instance does: +-- +-- >>> Aeson.encode bs64 +-- "\"Zm9vYmFy\"" +-- +-- This module uses standard alphabet +-- +-- >>> Aeson.encode (makeByteString64 "aa\191") +-- "\"YWG/\"" +-- +newtype ByteString64 = BS64 ByteString + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Show ByteString64 where + showsPrec d (BS64 bs) = showParen (d > 10) $ showString "mkBS64 " . showsPrec 11 bs + +-- | Wrap 'ByteString' into 'ByteString64'. Essentially 'coerce'. +makeByteString64 :: ByteString -> ByteString64 +makeByteString64 = BS64 + +-- | Shorter variant of 'makeByteString64' +mkBS64 :: ByteString -> ByteString64 +mkBS64 = makeByteString64 + +-- | Unwrap 'ByteString' from 'ByteString64'. Essentially 'coerce'. +getByteString64 :: ByteString64 -> ByteString +getByteString64 = \(BS64 bs) -> bs + +-- | Shorter variant of 'getByteString64' +getBS64 :: ByteString64 -> ByteString +getBS64 = \(BS64 bs) -> bs + +-- | Get base64 encode bytestring +-- +-- >>> getEncodedByteString64 "foobar" +-- "Zm9vYmFy" +-- +-- >>> getEncodedByteString64 "aa\191" +-- "YWG/" +-- +getEncodedByteString64 :: ByteString64 -> ByteString +getEncodedByteString64 = Base64.encode . getBS64 + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance IsString ByteString64 where + fromString = BS64 . fromString + +instance Semigroup ByteString64 where + BS64 a <> BS64 b = BS64 (a <> b) + +instance Monoid ByteString64 where + mempty = BS64 mempty + mappend = (<>) + +instance NFData ByteString64 where + rnf = rnf' . getBS64 where +#if MIN_VERSION_bytestring(0,10,0) + rnf' = rnf +#else + rnf' Empty = () + rnf' (Chunk _ b) = rnf' b +#endif + +instance Hashable ByteString64 + +------------------------------------------------------------------------------- +-- aeson +------------------------------------------------------------------------------- + +instance ToJSON ByteString64 where + toJSON = toJSON . decodeLatin1 . getEncodedByteString64 + toEncoding = toEncoding . decodeLatin1 . getEncodedByteString64 + +instance FromJSON ByteString64 where + parseJSON = withText "ByteString" $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 . fromStrict + +instance ToJSONKey ByteString64 where + toJSONKey = toJSONKeyText (toStrict . decodeLatin1 . getEncodedByteString64) + +instance FromJSONKey ByteString64 where + fromJSONKey = FromJSONKeyTextParser $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 . fromStrict + +------------------------------------------------------------------------------- +-- cereal +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Serialize ByteString64 + +------------------------------------------------------------------------------- +-- binary +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Binary ByteString64 where + put = put . getBS64 + get = fmap makeByteString64 get + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance Arbitrary ByteString64 where + arbitrary = BS64 . pack <$> arbitrary + shrink = shrinkMap (BS64 . pack) (unpack . getBS64) + +instance CoArbitrary ByteString64 where + coarbitrary = coarbitrary . unpack . getBS64 + +instance Function ByteString64 where + function = functionMap (unpack . getBS64) (BS64 . pack) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Binary as Binary +-- >>> import qualified Data.Aeson as Aeson diff --git a/src/Data/ByteString/Base64/Type.hs b/src/Data/ByteString/Base64/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/Type.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Strict 'ByteString' standard base64 encoding. +-- +-- See . +module Data.ByteString.Base64.Type ( + ByteString64, + makeByteString64, + getByteString64, + mkBS64, + getBS64, + getEncodedByteString64, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq (NFData (..)) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText) +import Data.Aeson.Types (FromJSONKeyFunction (..), toJSONKeyText) +import Data.Binary (Binary (..)) +import Data.ByteString (ByteString, pack, unpack) +import Data.Data (Data, Typeable) +import Data.Hashable (Hashable) +import Data.Semigroup (Semigroup (..)) +import Data.Serialize (Serialize) +import Data.String (IsString (..)) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import GHC.Generics (Generic) +import Test.QuickCheck + (Arbitrary (..), CoArbitrary (..), Function (..), functionMap, + shrinkMap) + +import qualified Data.ByteString.Base64 as Base64 + +-- | Aeson serialisable bytestring. Uses base64 encoding. +-- +-- The inner 'ByteString' is in raw format. +-- +-- >>> let bs64 = makeByteString64 "foobar" +-- >>> bs64 +-- mkBS64 "foobar" +-- +-- 'Binary' instance doesn't use base64 encoding: +-- +-- >>> Binary.encode bs64 +-- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ACKfoobar" +-- +-- 'Aeson' instance does: +-- +-- >>> Aeson.encode bs64 +-- "\"Zm9vYmFy\"" +-- +-- This module uses standard alphabet +-- +-- >>> Aeson.encode (makeByteString64 "aa\191") +-- "\"YWG/\"" +-- +newtype ByteString64 = BS64 ByteString + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Show ByteString64 where + showsPrec d (BS64 bs) = showParen (d > 10) $ showString "mkBS64 " . showsPrec 11 bs + +-- | Wrap 'ByteString' into 'ByteString64'. Essentially 'coerce'. + +-- | Wrap 'ByteString' into 'ByteString64'. Essentially 'coerce'. +makeByteString64 :: ByteString -> ByteString64 +makeByteString64 = BS64 + +-- | Shorter variant of 'makeByteString64' +mkBS64 :: ByteString -> ByteString64 +mkBS64 = makeByteString64 + +-- | Unwrap 'ByteString' from 'ByteString64'. Essentially 'coerce'. +getByteString64 :: ByteString64 -> ByteString +getByteString64 = \(BS64 bs) -> bs + +-- | Shorter variant of 'getByteString64' +getBS64 :: ByteString64 -> ByteString +getBS64 = \(BS64 bs) -> bs + +-- | Get base64 encode bytestring +-- +-- >>> getEncodedByteString64 "foobar" +-- "Zm9vYmFy" +-- +-- >>> getEncodedByteString64 "aa\191" +-- "YWG/" +-- +getEncodedByteString64 :: ByteString64 -> ByteString +getEncodedByteString64 = Base64.encode . getBS64 + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance IsString ByteString64 where + fromString = BS64 . fromString + +instance Semigroup ByteString64 where + BS64 a <> BS64 b = BS64 (a <> b) + +instance Monoid ByteString64 where + mempty = BS64 mempty + mappend = (<>) + +-- Instance is written like this to support bytestring-0.9 +instance NFData ByteString64 where rnf x = x `seq` () +instance Hashable ByteString64 + +------------------------------------------------------------------------------- +-- aeson +------------------------------------------------------------------------------- + +instance ToJSON ByteString64 where + toJSON = toJSON . decodeLatin1 . getEncodedByteString64 + toEncoding = toEncoding . decodeLatin1 . getEncodedByteString64 + +instance FromJSON ByteString64 where + parseJSON = withText "ByteString" $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 + +instance ToJSONKey ByteString64 where + toJSONKey = toJSONKeyText (decodeLatin1 . getEncodedByteString64) + +instance FromJSONKey ByteString64 where + fromJSONKey = FromJSONKeyTextParser $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 + +------------------------------------------------------------------------------- +-- cereal +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Serialize ByteString64 + +------------------------------------------------------------------------------- +-- binary +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Binary ByteString64 where + put = put . getBS64 + get = fmap makeByteString64 get + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance Arbitrary ByteString64 where + arbitrary = BS64 . pack <$> arbitrary + shrink = shrinkMap (BS64 . pack) (unpack . getBS64) + +instance CoArbitrary ByteString64 where + coarbitrary = coarbitrary . unpack . getBS64 + +instance Function ByteString64 where + function = functionMap (unpack . getBS64) (BS64 . pack) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Binary as Binary +-- >>> import qualified Data.Aeson as Aeson diff --git a/src/Data/ByteString/Base64/URL/Lazy/Type.hs b/src/Data/ByteString/Base64/URL/Lazy/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/URL/Lazy/Type.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Lazy 'ByteString' base64 encoding with URL and filename safe alphabet. +-- +-- See . +module Data.ByteString.Base64.URL.Lazy.Type ( + ByteString64, + makeByteString64, + getByteString64, + mkBS64, + getBS64, + getEncodedByteString64, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq (NFData (..)) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText) +import Data.Aeson.Types (FromJSONKeyFunction (..), toJSONKeyText) +import Data.Binary (Binary (..)) +import Data.ByteString.Lazy (ByteString, pack, unpack) +import Data.Data (Data, Typeable) +import Data.Hashable (Hashable) +import Data.Semigroup (Semigroup (..)) +import Data.Serialize (Serialize) +import Data.String (IsString (..)) +import Data.Text.Lazy (fromStrict, toStrict) +import Data.Text.Lazy.Encoding (decodeLatin1, encodeUtf8, ) +import GHC.Generics (Generic) +import Test.QuickCheck + (Arbitrary (..), CoArbitrary (..), Function (..), functionMap, + shrinkMap) + +import qualified Data.ByteString.Base64.URL.Lazy as Base64 + +#if !(MIN_VERSION_bytestring(0,10,0)) +import Data.ByteString.Lazy.Internal (ByteString (..)) +#endif + +-- | Aeson serialisable bytestring. Uses base64 encoding. +-- +-- The inner 'ByteString' is in raw format. +-- +-- >>> let bs64 = makeByteString64 "foobar" +-- >>> bs64 +-- mkBS64 "foobar" +-- +-- 'Binary' instance doesn't use base64 encoding: +-- +-- >>> Binary.encode bs64 +-- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ACKfoobar" +-- +-- 'Aeson' instance does: +-- +-- >>> Aeson.encode bs64 +-- "\"Zm9vYmFy\"" +-- +-- This module uses standard alphabet +-- +-- >>> Aeson.encode (makeByteString64 "aa\191") +-- "\"YWG_\"" +-- +newtype ByteString64 = BS64 ByteString + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Show ByteString64 where + showsPrec d (BS64 bs) = showParen (d > 10) $ showString "mkBS64 " . showsPrec 11 bs + +-- | Wrap 'ByteString' into 'ByteString64'. Essentially 'coerce'. +makeByteString64 :: ByteString -> ByteString64 +makeByteString64 = BS64 + +-- | Shorter variant of 'makeByteString64' +mkBS64 :: ByteString -> ByteString64 +mkBS64 = makeByteString64 + +-- | Unwrap 'ByteString' from 'ByteString64'. Essentially 'coerce'. +getByteString64 :: ByteString64 -> ByteString +getByteString64 = \(BS64 bs) -> bs + +-- | Shorter variant of 'getByteString64' +getBS64 :: ByteString64 -> ByteString +getBS64 = \(BS64 bs) -> bs + +-- | Get base64 encode bytestring +-- +-- >>> getEncodedByteString64 "foobar" +-- "Zm9vYmFy" +-- +-- >>> getEncodedByteString64 "aa\191" +-- "YWG_" +-- +getEncodedByteString64 :: ByteString64 -> ByteString +getEncodedByteString64 = Base64.encode . getBS64 + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance IsString ByteString64 where + fromString = BS64 . fromString + +instance Semigroup ByteString64 where + BS64 a <> BS64 b = BS64 (a <> b) + +instance Monoid ByteString64 where + mempty = BS64 mempty + mappend = (<>) + +instance NFData ByteString64 where + rnf = rnf' . getBS64 where +#if MIN_VERSION_bytestring(0,10,0) + rnf' = rnf +#else + rnf' Empty = () + rnf' (Chunk _ b) = rnf' b +#endif + +instance Hashable ByteString64 + +------------------------------------------------------------------------------- +-- aeson +------------------------------------------------------------------------------- + +instance ToJSON ByteString64 where + toJSON = toJSON . decodeLatin1 . getEncodedByteString64 + toEncoding = toEncoding . decodeLatin1 . getEncodedByteString64 + +instance FromJSON ByteString64 where + parseJSON = withText "ByteString" $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 . fromStrict + +instance ToJSONKey ByteString64 where + toJSONKey = toJSONKeyText (toStrict . decodeLatin1 . getEncodedByteString64) + +instance FromJSONKey ByteString64 where + fromJSONKey = FromJSONKeyTextParser $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 . fromStrict + +------------------------------------------------------------------------------- +-- cereal +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Serialize ByteString64 + +------------------------------------------------------------------------------- +-- binary +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Binary ByteString64 where + put = put . getBS64 + get = fmap makeByteString64 get + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance Arbitrary ByteString64 where + arbitrary = BS64 . pack <$> arbitrary + shrink = shrinkMap (BS64 . pack) (unpack . getBS64) + +instance CoArbitrary ByteString64 where + coarbitrary = coarbitrary . unpack . getBS64 + +instance Function ByteString64 where + function = functionMap (unpack . getBS64) (BS64 . pack) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Binary as Binary +-- >>> import qualified Data.Aeson as Aeson diff --git a/src/Data/ByteString/Base64/URL/Type.hs b/src/Data/ByteString/Base64/URL/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/URL/Type.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Strict 'ByteString' base64 encoding with URL and filename safe alphabet. +-- +-- See . +module Data.ByteString.Base64.URL.Type ( + ByteString64, + makeByteString64, + getByteString64, + mkBS64, + getBS64, + getEncodedByteString64, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq (NFData (..)) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText) +import Data.Aeson.Types (FromJSONKeyFunction (..), toJSONKeyText) +import Data.Binary (Binary (..)) +import Data.ByteString (ByteString, pack, unpack) +import Data.Data (Data, Typeable) +import Data.Hashable (Hashable) +import Data.Semigroup (Semigroup (..)) +import Data.Serialize (Serialize) +import Data.String (IsString (..)) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import GHC.Generics (Generic) +import Test.QuickCheck + (Arbitrary (..), CoArbitrary (..), Function (..), functionMap, + shrinkMap) + +import qualified Data.ByteString.Base64.URL as Base64 + +-- | Aeson serialisable bytestring. Uses base64 encoding. +-- +-- The inner 'ByteString' is in raw format. +-- +-- >>> let bs64 = makeByteString64 "foobar" +-- >>> bs64 +-- mkBS64 "foobar" +-- +-- 'Binary' instance doesn't use base64 encoding: +-- +-- >>> Binary.encode bs64 +-- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ACKfoobar" +-- +-- 'Aeson' instance does: +-- +-- >>> Aeson.encode bs64 +-- "\"Zm9vYmFy\"" +-- +-- This module uses standard alphabet +-- +-- >>> Aeson.encode (makeByteString64 "aa\191") +-- "\"YWG_\"" +-- +newtype ByteString64 = BS64 ByteString + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Show ByteString64 where + showsPrec d (BS64 bs) = showParen (d > 10) $ showString "mkBS64 " . showsPrec 11 bs + +-- | Wrap 'ByteString' into 'ByteString64'. Essentially 'coerce'. +makeByteString64 :: ByteString -> ByteString64 +makeByteString64 = BS64 + +-- | Shorter variant of 'makeByteString64' +mkBS64 :: ByteString -> ByteString64 +mkBS64 = makeByteString64 + +-- | Unwrap 'ByteString' from 'ByteString64'. Essentially 'coerce'. +getByteString64 :: ByteString64 -> ByteString +getByteString64 = \(BS64 bs) -> bs + +-- | Shorter variant of 'getByteString64' +getBS64 :: ByteString64 -> ByteString +getBS64 = \(BS64 bs) -> bs + +-- | Get base64 encode bytestring +-- +-- >>> getEncodedByteString64 "foobar" +-- "Zm9vYmFy" +-- +-- >>> getEncodedByteString64 "aa\191" +-- "YWG_" +-- +getEncodedByteString64 :: ByteString64 -> ByteString +getEncodedByteString64 = Base64.encode . getBS64 + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance IsString ByteString64 where + fromString = BS64 . fromString + +instance Semigroup ByteString64 where + BS64 a <> BS64 b = BS64 (a <> b) + +instance Monoid ByteString64 where + mempty = BS64 mempty + mappend = (<>) + +instance NFData ByteString64 where rnf x = x `seq` () +instance Hashable ByteString64 + +------------------------------------------------------------------------------- +-- aeson +------------------------------------------------------------------------------- + +instance ToJSON ByteString64 where + toJSON = toJSON . decodeLatin1 . getEncodedByteString64 + toEncoding = toEncoding . decodeLatin1 . getEncodedByteString64 + +instance FromJSON ByteString64 where + parseJSON = withText "ByteString" $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 + +instance ToJSONKey ByteString64 where + toJSONKey = toJSONKeyText (decodeLatin1 . getEncodedByteString64) + +instance FromJSONKey ByteString64 where + fromJSONKey = FromJSONKeyTextParser $ + either fail (pure . BS64) . Base64.decode . encodeUtf8 + +------------------------------------------------------------------------------- +-- cereal +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Serialize ByteString64 + +------------------------------------------------------------------------------- +-- binary +------------------------------------------------------------------------------- + +-- | 'ByteString64' is serialised as 'ByteString' +instance Binary ByteString64 where + put = put . getBS64 + get = fmap makeByteString64 get + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance Arbitrary ByteString64 where + arbitrary = BS64 . pack <$> arbitrary + shrink = shrinkMap (BS64 . pack) (unpack . getBS64) + +instance CoArbitrary ByteString64 where + coarbitrary = coarbitrary . unpack . getBS64 + +instance Function ByteString64 where + function = functionMap (unpack . getBS64) (BS64 . pack) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Binary as Binary +-- >>> import qualified Data.Aeson as Aeson diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,77 @@ +module Main (main) where + +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty, (===)) + +import qualified Data.Aeson as A +import qualified Data.Binary as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.Lazy.Type as L +import qualified Data.ByteString.Base64.Type as S +import qualified Data.ByteString.Base64.URL.Lazy.Type as UL +import qualified Data.ByteString.Base64.URL.Type as US +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Serialize as C + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ aeson + , binary + , cereal + ] + +aeson :: TestTree +aeson = testGroup "Aeson" + [ testProperty "strict" propS + , testProperty "lazy" propL + , testProperty "strict url" propUL + , testProperty "lazy url" propUS + ] + where + propS bs64 = A.decode (A.encode bs64) === Just (bs64 :: S.ByteString64) + propL bs64 = A.decode (A.encode bs64) === Just (bs64 :: L.ByteString64) + propUL bs64 = A.decode (A.encode bs64) === Just (bs64 :: UL.ByteString64) + propUS bs64 = A.decode (A.encode bs64) === Just (bs64 :: US.ByteString64) + +binary :: TestTree +binary = testGroup "Binary" + [ testProperty "strict" propS + , testProperty "lazy" propL + , testProperty "strict url" propUL + , testProperty "lazy url" propUS + ] + where + propS ws = let bs64 = S.makeByteString64 (BS.pack ws) + in B.decode (B.encode bs64) === bs64 + + propL ws = let bs64 = L.makeByteString64 (LBS.pack ws) + in B.decode (B.encode bs64) === bs64 + + propUS ws = let bs64 = US.makeByteString64 (BS.pack ws) + in B.decode (B.encode bs64) === bs64 + + propUL ws = let bs64 = UL.makeByteString64 (LBS.pack ws) + in B.decode (B.encode bs64) === bs64 + +cereal :: TestTree +cereal = testGroup "Cereal" + [ testProperty "strict" propS + , testProperty "lazy" propL + , testProperty "strict url" propUL + , testProperty "lazy url" propUS + ] + where + propS ws = let bs64 = S.makeByteString64 (BS.pack ws) + in C.decode (C.encode bs64) === Right bs64 + + propL ws = let bs64 = L.makeByteString64 (LBS.pack ws) + in C.decode (C.encode bs64) === Right bs64 + + propUS ws = let bs64 = US.makeByteString64 (BS.pack ws) + in C.decode (C.encode bs64) === Right bs64 + + propUL ws = let bs64 = UL.makeByteString64 (LBS.pack ws) + in C.decode (C.encode bs64) === Right bs64