base64-2.1: test/Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
-- |
-- Module : Main
-- Copyright : (c) 2019-2026 Emily Pillmore
-- License : BSD-style
--
-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>
-- Stability : Experimental
-- Portability : portable
--
-- This module contains the test implementation for the `base64` package
--
module Main
( main
) where
import Prelude hiding (length)
import Data.Base64.Types
import Data.Bifunctor (second)
import qualified Data.ByteString as BS
import Data.ByteString.Internal (c2w)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short as SBS
import "base64" Data.ByteString.Base64 as B64
import "base64" Data.ByteString.Base64.URL as B64U
import qualified "base64-bytestring" Data.ByteString.Base64 as Bos
import qualified "base64-bytestring" Data.ByteString.Base64.URL as BosU
import Data.Either (isLeft)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Encoding.Base64.Error (Base64Error(..))
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Short as TS
import Data.Word
import Internal
import qualified Simd
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck (testProperty)
import Data.String (IsString, fromString)
import Test.QuickCheck hiding (label)
main :: IO ()
main = defaultMain tests
tests :: TestTree
#ifdef BASE64_SIMD
tests = testGroup "Base64 Tests (simd enabled)"
#else
tests = testGroup "Base64 Tests (scalar)"
#endif
[ Simd.tests
, mkTree b64
[ mkPropTree
, mkUnitTree BS.last BS.length
]
, mkTree lb64
[ mkPropTree
, mkUnitTree LBS.last (fromIntegral . LBS.length)
]
, mkTree sb64
[ mkPropTree
, mkUnitTree (BS.last . SBS.fromShort) SBS.length
]
, mkTree t64
[ mkPropTree
, mkUnitTree (c2w . T.last) T.length
, mkDecodeTree T.decodeUtf8' tt64 b64
]
, mkTree tl64
[ mkPropTree
, mkUnitTree (c2w . TL.last) (fromIntegral . TL.length)
, mkDecodeTree TL.decodeUtf8' ttl64 lb64
]
, mkTree ts64
[ mkPropTree
, mkUnitTree (c2w . T.last . TS.toText) TS.length
, mkDecodeTree
(second TS.fromText . T.decodeUtf8' . SBS.fromShort) tts64 sb64
]
, parseRepresentationTests
, urlParseRepresentationTests
, parserCoherenceTests
]
-- ---------------------------------------------------------------- --
-- Test tree generation
-- | Make a test tree for a given label
--
mkTree
:: ( Arbitrary a
, IsString a
, Eq a
, Show a
)
=> Harness a
-> [Harness a -> TestTree]
-> TestTree
mkTree a = testGroup (label a) . fmap ($ a)
-- | Make a test group with some name, lifting a test tree up to the correct
-- type information via some Harness
--
mkTests
:: ( Arbitrary a
, IsString a
, Eq a
, Show a
)
=> String
-> [Harness a -> TestTree]
-> Harness a
-> TestTree
mkTests context ts = testGroup context . (<*>) ts . pure
-- | Make property tests for a given harness instance
--
mkPropTree :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree
mkPropTree = mkTests "Property Tests"
[ prop_roundtrip
, prop_parse
, prop_parse_url
, prop_url_padding
, const prop_bos_coherence
]
-- | Make unit tests for a given harness instance
--
mkUnitTree
:: (Arbitrary a, IsString a, Eq a, Show a)
=> (a -> Word8)
-> (a -> Int)
-> Harness a
-> TestTree
mkUnitTree last_ length_ = mkTests "Unit tests"
[ paddingTests last_ length_
, rfcVectors
, offsetVectors
, urlParseTests
, canonicityTests
, parseTests
]
-- | Make unit tests for textual 'decode*With' functions
--
mkDecodeTree
:: ( Arbitrary t
, Eq t
, IsString t
, Show t
, IsString a
, Show e
)
=> (a -> Either e t)
-> TextHarness a t
-> Harness a
-> Harness t
-> TestTree
mkDecodeTree utf8 t a = mkTests "Decoding tests"
[ decodeWithVectors utf8 t a
]
-- ---------------------------------------------------------------- --
-- Property tests
prop_roundtrip :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree
prop_roundtrip Harness{..} = testGroup "prop_roundtrip"
[ testProperty "prop_std_roundtrip" $ \(bs :: a) ->
Right bs == decode (extractBase64 $ encode bs)
, testProperty "prop_url_roundtrip" $ \(bs :: a) ->
Right bs == decodeUrl (extractBase64 $ encodeUrl bs)
, testProperty "prop_url_roundtrip_nopad" $ \(bs :: a) ->
Right bs
== decodeUrlNopad (extractBase64 $ encodeUrlNopad bs)
, testProperty "prop_std_lenient_roundtrip" $ \(bs :: a) ->
bs == lenient (extractBase64 $ encode bs)
, testProperty "prop_url_lenient_roundtrip" $ \(bs :: a) ->
bs == lenientUrl (extractBase64 $ encodeUrl bs)
]
prop_parse :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree
prop_parse Harness{..} = testGroup "Parsing properties"
[ testProperty "parse an encoded value" $ \(bs :: a) ->
parse (extractBase64 $ encode bs) === Right (encode bs)
, testProperty "decode a parsed value" $ \(bs :: a) ->
fmap decodeTyped (parse $ extractBase64 $ encode bs) === Right bs
, testProperty "preserve the encoded input" $ \(bs :: a) ->
case parse bs of
Left _ -> property True
Right encoded -> extractBase64 encoded === bs
, testProperty "agree with untyped decoding errors" $ \(bs :: a) ->
-- Discard the decoded payload without forcing a possible UTF-8 conversion.
(() <$ parse bs) === (() <$ decode bs)
]
parseTests :: (IsString a, Eq a, Show a) => Harness a -> TestTree
parseTests Harness{..} = testGroup "Parsing unit tests"
[ testGroup "Preserve valid encoded values"
[ testCase (show input) $
parse input @?= Right (assertBase64 input)
| input <- [ "", "Zg==", "Zm8=", "Zm9v", "Zm9vYg=="
, "Zm9vYmE=", "Zm9vYmFy", "PDw/Pz4+"
, "/w==" -- Valid Base64 whose decoded byte is not valid UTF-8.
]
]
, testGroup "Reject malformed and non-canonical values"
[ testCase (show input) $ parse input @?= Left err
| (input, err) <-
[ ("Z", "Base64-encoded bytestring has invalid size")
, ("Zg", "Base64-encoded bytestring requires padding")
, ("Zm8", "Base64-encoded bytestring requires padding")
, ("Zg===", "Base64-encoded bytestring has invalid size")
, ("====", "invalid padding near offset: 0")
, ("A===", "invalid padding near offset: 1")
, ("AA=A", "invalid base64 encoding near offset: 3")
, ("Zg==AAAA", "invalid padding near offset: 2")
, ("Zm8=AAAA", "invalid padding near offset: 3")
, ("%AAA", "invalid base64 encoding near offset: 0")
, ("A%AA", "invalid base64 encoding near offset: 1")
, ("AA%A", "invalid base64 encoding near offset: 2")
, ("AAA%", "invalid base64 encoding near offset: 3")
, ("AAAA%AAA", "invalid base64 encoding near offset: 4")
, ("PDw_", "invalid base64 encoding near offset: 3")
, ("PDw-", "invalid base64 encoding near offset: 3")
, ("AAA ", "invalid base64 encoding near offset: 3")
, ("AAA\n", "invalid base64 encoding near offset: 3")
, ("ZE==", "non-canonical encoding detected at offset: 1")
, ("ZmC=", "non-canonical encoding detected at offset: 2")
, ("Zm9vYE==", "non-canonical encoding detected at offset: 5")
, ("Zm9vYmC=", "non-canonical encoding detected at offset: 6")
]
]
, testCase "reject non-ASCII input" $
assertBool "non-ASCII input was accepted" $
isLeft (parse "\255\255\255\255")
]
parseRepresentationTests :: TestTree
parseRepresentationTests = testGroup "Parsing representations"
[ testProperty "parse sliced ByteStrings" $ \bs ->
let input = extractBase64 (B64.encodeBase64' bs)
sliced = BS.take (BS.length input) $ BS.drop 2 ("!!" <> input <> "!!")
in B64.parseBase64 sliced === Right (assertBase64 input)
, testCase "error offsets are relative to the ByteString slice" $
B64.parseBase64 (BS.take 4 $ BS.drop 2 "!!AA%A!!")
@?= Left "invalid base64 encoding near offset: 2"
, testGroup "Lazy ByteString chunk boundaries"
[ testCase (show (input, n)) $
let chunks = [BS.take n input, BS.drop n input]
bytes = LBS.fromChunks chunks
in fmap (fmap LBS.toStrict) (parse lb64 bytes)
@?= B64.parseBase64 input
| input <- ["Zg==", "Zm9vYmFy", "Zg==AAAA", "Zm9vYmC=", "Zg", "AAAA%AAA"]
, n <- [0 .. BS.length input]
]
, testGroup "Lazy Text chunk boundaries"
[ testCase (show (input, n)) $
let chunks = [T.take n input, T.drop n input]
txt = TL.fromChunks chunks
in fmap (fmap TL.toStrict) (parse tl64 txt)
@?= parse t64 input
| input <- ["Zg==", "Zm9vYmFy", "Zg==AAAA", "Zm9vYmC=", "Zg", "AAAA%AAA"]
, n <- [0 .. T.length input]
]
, testCase "preserve lazy ByteString chunks, including split padding" $ do
let chunks = ["Z", "g=", "="]
fmap (LBS.toChunks . extractBase64) (parse lb64 $ LBS.fromChunks chunks)
@?= Right chunks
, testCase "preserve lazy Text chunks, including split padding" $ do
let chunks = ["Z", "g=", "="]
fmap (TL.toChunks . extractBase64) (parse tl64 $ TL.fromChunks chunks)
@?= Right chunks
]
prop_parse_url :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree
prop_parse_url Harness{..} = testGroup "URL parsing properties"
[ parserProperties "padded" parseUrlPad encodeUrl decodeUrlTypedPad decodeUrlPad
, parserProperties "unpadded" parseUrlNopad encodeUrlNopad decodeUrlTypedNopad decodeUrlNopad
]
where
parserProperties name parser encoder decoder untyped = testGroup name
[ testProperty "parse an encoded value" $ \bs ->
parser (extractBase64 $ encoder bs) === Right (encoder bs)
, testProperty "decode a parsed value" $ \bs ->
fmap decoder (parser $ extractBase64 $ encoder bs) === Right bs
, testProperty "preserve arbitrary accepted input" $ \bs ->
case parser bs of
Left _ -> property True
Right encoded -> extractBase64 encoded === bs
, testProperty "agree with untyped decoding errors" $ \bs ->
-- Do not force a possible UTF-8 conversion of the decoded payload.
(() <$ parser bs) === (() <$ untyped bs)
, testProperty "validate arbitrary alphabet and padding combinations" $
forAll (listOf $ elements "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_=+/% \n") $ \s ->
let input = fromString s
in (extractBase64 <$> parser input) === (input <$ untyped input)
]
urlParseTests :: (IsString a, Eq a, Show a) => Harness a -> TestTree
urlParseTests Harness{..} = testGroup "URL parsing unit tests"
[ testGroup "Preserve valid padded values"
[ testCase (show input) $ parseUrlPad input @?= Right (assertBase64 input)
| input <- ["", "Zg==", "Zm8=", "Zm9v", "Zm9vYg==", "Zm9vYmE=", "Zm9vYmFy"
, "PDw_Pj4=", "PDw_Pz4-", "_w==", "-_8=", "PA==", "PDw=", "PDw_"
, "ZA==", "ZmA=", "Zm9vYmA="]
]
, testGroup "Preserve valid unpadded values"
[ testCase (show input) $ parseUrlNopad input @?= Right (assertBase64 input)
| input <- ["", "Zg", "Zm8", "Zm9v", "Zm9vYg", "Zm9vYmE", "Zm9vYmFy"
, "PDw_Pj4", "PDw_Pz4-", "_w", "-_8", "PA", "PDw", "PDw_"
, "ZA", "ZmA", "Zm9vYmA"]
]
, testGroup "Require complete padding for UrlPadded"
[ testCase (show input) $
parseUrlPad input @?= Left "Base64-encoded bytestring requires padding"
| input <- ["Zg", "Zm8", "Zg=", "PDw_Pj4"]
]
, testGroup "Reject padding for UrlUnpadded"
[ testCase (show input) $
parseUrlNopad input @?= Left "Base64-encoded bytestring has invalid padding"
| input <- ["Zg==", "Zm8=", "Zg=", "==", "====", "PDw_Pj4="]
]
, testGroup "Reject malformed values in both modes"
[ testGroup name
[ testCase (show input) $ parser input @?= Left err
| (input, err) <-
[ ("Z", "Base64-encoded bytestring has invalid size")
, ("Zg===", "Base64-encoded bytestring has invalid size")
, ("AA=A", "invalid base64 encoding near offset: 3")
, ("Zg==AAAA", "invalid padding near offset: 2")
, ("Zm8=AAAA", "invalid padding near offset: 3")
, ("%AAA", "invalid base64 encoding near offset: 0")
, ("A%AA", "invalid base64 encoding near offset: 1")
, ("AA%A", "invalid base64 encoding near offset: 2")
, ("AAA%", "invalid base64 encoding near offset: 3")
, ("AAAA%AAA", "invalid base64 encoding near offset: 4")
, ("PDw/", "invalid base64 encoding near offset: 3")
, ("PDw+", "invalid base64 encoding near offset: 3")
, ("AAA ", "invalid base64 encoding near offset: 3")
, ("AAA\n", "invalid base64 encoding near offset: 3")
]
]
| (name, parser) <- [("padded", fmap extractBase64 . parseUrlPad)
, ("unpadded", fmap extractBase64 . parseUrlNopad)]
]
, testGroup "Reject invalid padded quanta"
[ testCase (show input) $ parseUrlPad input @?= Left err
| (input, err) <- [("====", "invalid padding near offset: 0")
, ("A===", "invalid padding near offset: 1")]
]
, testGroup "Reject non-canonical values in both modes"
[ testCase (show (padded, unpadded)) $ do
parseUrlPad padded @?= Left err
parseUrlNopad unpadded @?= Left err
| (padded, unpadded, err) <-
[ ("ZE==", "ZE", "non-canonical encoding detected at offset: 1")
, ("ZK==", "ZK", "non-canonical encoding detected at offset: 1")
, ("ZmC=", "ZmC", "non-canonical encoding detected at offset: 2")
, ("ZmD=", "ZmD", "non-canonical encoding detected at offset: 2")
, ("_x==", "_x", "non-canonical encoding detected at offset: 1")
, ("-_9=", "-_9", "non-canonical encoding detected at offset: 2")
, ("Zm9vYE==", "Zm9vYE", "non-canonical encoding detected at offset: 5")
, ("Zm9vYmC=", "Zm9vYmC", "non-canonical encoding detected at offset: 6")
]
]
, testCase "reject non-ASCII input in both modes" $ do
assertBool "padded parser accepted non-ASCII input" $
isLeft (parseUrlPad "\255\255\255\255")
assertBool "unpadded parser accepted non-ASCII input" $
isLeft (parseUrlNopad "\255\255\255\255")
]
urlParseRepresentationTests :: TestTree
urlParseRepresentationTests = testGroup "URL parsing representations"
[ testGroup name
[ testProperty "parse sliced ByteStrings" $ \bs ->
let input = encoder bs
sliced = BS.take (BS.length input) $ BS.drop 2 ("!!" <> input <> "!!")
in parser sliced === Right input
, testCase "error offsets are relative to the ByteString slice" $
parser (BS.take 4 $ BS.drop 2 "!!AA%A!!")
@?= Left "invalid base64 encoding near offset: 2"
, testGroup "Lazy ByteString chunk boundaries"
[ testCase (show (input, n)) $
let splitChunks = [BS.take n input, BS.drop n input]
in fmap LBS.toStrict (lazyParser $ LBS.fromChunks splitChunks) @?= parser input
| input <- inputs
, n <- [0 .. BS.length input]
]
, testGroup "Lazy Text chunk boundaries"
[ testCase (show (input, n)) $
let txt = T.decodeUtf8 input
splitChunks = [T.take n txt, T.drop n txt]
in fmap TL.toStrict (lazyTextParser $ TL.fromChunks splitChunks) @?= textParser txt
| input <- inputs
, n <- [0 .. BS.length input]
]
, testCase "preserve lazy ByteString chunks" $
fmap LBS.toChunks (lazyParser $ LBS.fromChunks chunks) @?= Right chunks
, testCase "preserve lazy Text chunks" $
let textChunks = fmap T.decodeUtf8 chunks
in fmap TL.toChunks (lazyTextParser $ TL.fromChunks textChunks) @?= Right textChunks
]
| (name, encoder, parser, lazyParser, textParser, lazyTextParser, chunks) <-
[ ("padded", extractBase64 . B64U.encodeBase64'
, fmap extractBase64 . parseUrlPad b64, fmap extractBase64 . parseUrlPad lb64
, fmap extractBase64 . parseUrlPad t64, fmap extractBase64 . parseUrlPad tl64
, ["_", "w=", "="])
, ("unpadded", extractBase64 . B64U.encodeBase64Unpadded'
, fmap extractBase64 . parseUrlNopad b64, fmap extractBase64 . parseUrlNopad lb64
, fmap extractBase64 . parseUrlNopad t64, fmap extractBase64 . parseUrlNopad tl64
, ["P", "Dw_", "Pj4"])
]
]
where
inputs =
[ "", "_w==", "_w", "PDw_Pj4=", "PDw_Pj4", "PDw_Pz4-", "Zg==AAAA"
, "Zm9vYmC=", "Zm9vYmC", "Zg=", "A", "AAAA%AAA", "AA=A", "===="
, BS.replicate 64 65 <> "-_8=", BS.replicate 64 65 <> "-_8"
, BS.replicate 64 65 <> "AA%A", BS.replicate 64 65 <> "-_9="
]
parserCoherenceTests :: TestTree
parserCoherenceTests = testGroup "Parser consistency across all representations"
[ testProperty name $
forAll (listOf $ resize 8 $ listOf1 $ elements alphabet) $ \chunks ->
let textChunks = fmap T.pack chunks
byteChunks = fmap T.encodeUtf8 textChunks
textInput = T.concat textChunks
byteInput = BS.concat byteChunks
expected = strictBytes byteInput
in conjoin
[ counterexample "lazy ByteString" $
(LBS.toStrict <$> lazyBytes (LBS.fromChunks byteChunks)) === expected
, counterexample "short ByteString" $
(SBS.fromShort <$> shortBytes (SBS.toShort byteInput)) === expected
, counterexample "strict Text" $
(T.encodeUtf8 <$> strictText textInput) === expected
, counterexample "lazy Text" $
(T.encodeUtf8 . TL.toStrict <$> lazyText (TL.fromChunks textChunks)) === expected
, counterexample "short Text" $
(TS.toByteString <$> shortText (TS.fromText textInput)) === expected
]
| (name, strictBytes, lazyBytes, shortBytes, strictText, lazyText, shortText) <-
[ ("standard padded"
, fmap extractBase64 . parse b64, fmap extractBase64 . parse lb64
, fmap extractBase64 . parse sb64, fmap extractBase64 . parse t64
, fmap extractBase64 . parse tl64, fmap extractBase64 . parse ts64)
, ("URL padded"
, fmap extractBase64 . parseUrlPad b64, fmap extractBase64 . parseUrlPad lb64
, fmap extractBase64 . parseUrlPad sb64, fmap extractBase64 . parseUrlPad t64
, fmap extractBase64 . parseUrlPad tl64, fmap extractBase64 . parseUrlPad ts64)
, ("URL unpadded"
, fmap extractBase64 . parseUrlNopad b64, fmap extractBase64 . parseUrlNopad lb64
, fmap extractBase64 . parseUrlNopad sb64, fmap extractBase64 . parseUrlNopad t64
, fmap extractBase64 . parseUrlNopad tl64, fmap extractBase64 . parseUrlNopad ts64)
]
]
where
alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=_-% \n\255\955\128512"
prop_url_padding :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree
prop_url_padding Harness{..} = testGroup "prop_url_padding"
[ testProperty "prop_url_nopad_roundtrip_untyped" $ \(bs :: a) ->
Right bs
== decodeUrlNopad (extractBase64 $ encodeUrlNopad bs)
, testProperty "prop_url_nopad_roundtrip_typed" $ \(bs :: a) ->
bs == decodeUrlTypedNopad (encodeUrlNopad bs)
, testProperty "prop_url_pad_roundtrip_untyped" $ \(bs :: a) ->
Right bs == decodeUrlPad (extractBase64 $ encodeUrl bs)
, testProperty "prop_url_pad_roundtrip_typed" $ \(bs :: a) ->
bs == decodeUrlTypedPad (encodeUrl bs)
, testProperty "prop_url_decode_invariant_untyped" $ \(bs :: a) ->
(decodeUrlNopad (extractBase64 $ encodeUrlNopad bs)
== decodeUrl (extractBase64 $ encodeUrlNopad bs))
||
(decodeUrlPad (extractBase64 $ encodeUrl bs)
== decodeUrl (extractBase64 $ encodeUrl bs))
, testProperty "prop_url_decode_invariant_typed" $ \(bs :: a) ->
(decodeUrlTypedNopad (encodeUrlNopad bs)
== decodeUrlTyped (encodeUrlNopad bs))
||
(decodeUrlPad (extractBase64 $ encodeUrl bs)
== decodeUrl (extractBase64 $ encodeUrl bs))
-- NOTE: we need to fix the bitmasking issue for "impossible"
-- inputs
, testProperty "prop_url_padding_coherence" $ \(bs :: a) ->
Right bs == decodeUrl (extractBase64 $ encodeUrl bs)
&& Right bs == decodeUrlPad (extractBase64 $ encodeUrl bs)
, testProperty "prop_url_nopadding_coherence" $ \(bs :: a) ->
Right bs == decodeUrlNopad (extractBase64 $ encodeUrlNopad bs)
&& Right bs == decodeUrl (extractBase64 $ encodeUrlNopad bs)
]
-- | just a sanity check against `base64-bytestring`
--
prop_bos_coherence :: TestTree
prop_bos_coherence = testGroup "prop_bos_coherence"
[ testProperty "prop_std_bos_coherence" $ \bs ->
Right bs == B64.decodeBase64Untyped (extractBase64 $ B64.encodeBase64' bs)
&& Right bs == Bos.decode (Bos.encode bs)
&& bs == B64.decodeBase64 (B64.encodeBase64' bs)
, testProperty "prop_url_bos_coherence" $ \bs ->
Right bs == B64U.decodeBase64Untyped (extractBase64 $ B64U.encodeBase64' bs)
&& Right bs == BosU.decode (BosU.encode bs)
&& bs == B64U.decodeBase64 (B64U.encodeBase64' bs)
]
-- ---------------------------------------------------------------- --
-- Unit tests
-- | RFC 4648 test vectors
--
rfcVectors :: (IsString a, Eq a, Show a) => Harness a -> TestTree
rfcVectors Harness{..} = testGroup "RFC 4648 Test Vectors"
[ testGroup "std alphabet"
[ testCaseStd "" ""
, testCaseStd "f" "Zg=="
, testCaseStd "f" "Zg=="
, testCaseStd "fo" "Zm8="
, testCaseStd "foo" "Zm9v"
, testCaseStd "foob" "Zm9vYg=="
, testCaseStd "fooba" "Zm9vYmE="
, testCaseStd "foobar" "Zm9vYmFy"
]
, testGroup "url-safe alphabet"
[ testCaseUrl "" ""
, testCaseUrl "<" "PA=="
, testCaseUrl "<<" "PDw="
, testCaseUrl "<<?" "PDw_"
, testCaseUrl "<<??" "PDw_Pw=="
, testCaseUrl "<<??>" "PDw_Pz4="
, testCaseUrl "<<??>>" "PDw_Pz4-"
]
]
where
testCaseStd s t =
testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do
step "encode is sound"
assertBase64 t @=? encode s
step "decode is sound - untyped"
Right s @=? decode (extractBase64 $ encode s)
Right s @=? decode t
step "decode is sound - typed"
s @=? decodeTyped (encode s)
s @=? decodeTyped (assertBase64 t)
testCaseUrl s t =
testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do
step "encode is sound"
assertBase64 t @=? encodeUrl s
step "decode is sound - untyped"
Right s @=? decodeUrl (extractBase64 $ encodeUrl s)
Right s @=? decodeUrl t
step "decode is sound - typed"
s @=? decodeUrlTyped (encodeUrl s)
s @=? decodeUrlTypedPad (encodeUrl s)
s @=? decodeUrlTyped (assertBase64 @'UrlPadded t)
s @=? decodeUrlTypedPad (assertBase64 @'UrlPadded t)
-- | Url-safe padding unit tests (stresses entire alphabet)
--
paddingTests
:: ( IsString a
, Eq a
, Show a
)
=> (a -> Word8)
-> (a -> Int)
-> Harness a
-> TestTree
paddingTests last_ length_ Harness{..} = testGroup "Padding tests"
[ testGroup "URL decodePadding coherence"
[ ptest "<" "PA=="
, ptest "<<" "PDw="
, ptest "<<?" "PDw_"
, ptest "<<??" "PDw_Pw=="
, ptest "<<??>" "PDw_Pz4="
, ptest "<<??>>" "PDw_Pz4-"
]
, testGroup "URL decodeUnpadded coherence"
[ utest "<" "PA"
, utest "<<" "PDw"
, utest "<<?" "PDw_"
, utest "<<??" "PDw_Pw"
, utest "<<??>" "PDw_Pz4"
, utest "<<??>>" "PDw_Pz4-"
]
, testGroup "url-safe padding case unit tests"
[ testCase "stress arbitarily padded URL strings" $ do
decodeUrl "P" @=? Left "Base64-encoded bytestring has invalid size"
decodeUrl "PA" @=? Right "<"
decodeUrl "PDw" @=? Right "<<"
decodeUrl "PDw_" @=? Right "<<?"
, testCase "stress padded URL strings" $ do
decodeUrlPad "=" @=? Left "Base64-encoded bytestring has invalid size"
decodeUrlPad "PA==" @=? Right "<"
decodeUrlPad "PDw=" @=? Right "<<"
decodeUrlPad "PDw_" @=? Right "<<?"
, testCase "stress unpadded URL strings" $ do
decodeUrlNopad "P" @=? Left "Base64-encoded bytestring has invalid size"
decodeUrlNopad "PA" @=? Right "<"
decodeUrlNopad "PDw" @=? Right "<<"
decodeUrlNopad "PDw_" @=? Right "<<?"
]
]
where
ptest s t =
testCaseSteps (show $ if t == "" then "empty" else t) $ \step -> do
let u = decodeUrlNopad t
v = decodeUrlPad t
if last_ t == 0x3d then do
step "Padding required: no padding fails"
u @=? Left "Base64-encoded bytestring has invalid padding"
step "Padding required: padding succeeds"
v @=? Right s
else do
step "String has no padding: decodes should coincide"
u @=? Right s
v @=? Right s
v @=? u
utest s t =
testCaseSteps (show $ if t == "" then "empty" else t) $ \step -> do
let u = decodeUrlPad t
v = decodeUrlNopad t
if length_ t `mod` 4 == 0 then do
step "String has no padding: decodes should coincide"
u @=? Right s
v @=? Right s
v @=? u
else do
step "Unpadded required: padding fails"
u @=? Left "Base64-encoded bytestring requires padding"
step "Unpadded required: unpadding succeeds"
v @=? Right s
-- | Offset test vectors. This stresses the invalid char + incorrect padding
-- offset error messages
--
offsetVectors :: (IsString a, Eq a, Show a) => Harness a -> TestTree
offsetVectors Harness{..} = testGroup "Offset tests"
[ testGroup "Invalid padding"
[ testCase "Invalid staggered padding" $ do
decodeUrl "=A==" @=? Left "invalid padding near offset: 0"
decodeUrl "P===" @=? Left "invalid padding near offset: 1"
, testCase "Invalid character coverage - final chunk" $ do
decodeUrl "%D==" @=? Left "invalid base64 encoding near offset: 0"
decodeUrl "P%==" @=? Left "invalid base64 encoding near offset: 1"
decodeUrl "PD%=" @=? Left "invalid base64 encoding near offset: 2"
decodeUrl "PA=%" @=? Left "invalid base64 encoding near offset: 3"
decodeUrl "PDw%" @=? Left "invalid base64 encoding near offset: 3"
, testCase "Invalid character coverage - decode chunk" $ do
decodeUrl "%Dw_PDw_" @=? Left "invalid base64 encoding near offset: 0"
decodeUrl "P%w_PDw_" @=? Left "invalid base64 encoding near offset: 1"
decodeUrl "PD%_PDw_" @=? Left "invalid base64 encoding near offset: 2"
decodeUrl "PDw%PDw_" @=? Left "invalid base64 encoding near offset: 3"
, testCase "Invalid padding in body" $ do
decodeUrl "PD=_PDw_" @=? Left "invalid padding near offset: 2"
decodeUrl "PDw=PDw_" @=? Left "invalid padding near offset: 3"
, testCase "Padding fails everywhere but end" $ do
decode "=eAoeAo=" @=? Left "invalid padding near offset: 0"
decode "e=AoeAo=" @=? Left "invalid padding near offset: 1"
decode "eA=oeAo=" @=? Left "invalid padding near offset: 2"
decode "eAo=eAo=" @=? Left "invalid padding near offset: 3"
decode "eAoe=Ao=" @=? Left "invalid padding near offset: 4"
decode "eAoeA=o=" @=? Left "invalid padding near offset: 5"
]
]
canonicityTests :: (IsString a, Eq a, Show a) => Harness a -> TestTree
canonicityTests Harness{..} = testGroup "Canonicity unit tests"
[ testCase "roundtrip for d ~ ZA==" $ do
decode "ZE==" @=? Left "non-canonical encoding detected at offset: 1"
decode "ZK==" @=? Left "non-canonical encoding detected at offset: 1"
decode "ZA==" @=? Right "d"
, testCase "roundtrip for f` ~ ZmA=" $ do
decode "ZmC=" @=? Left "non-canonical encoding detected at offset: 2"
decode "ZmD=" @=? Left "non-canonical encoding detected at offset: 2"
decode "ZmA=" @=? Right "f`"
, testCase "roundtrip for foo` ~ Zm9vYA==" $ do
decode "Zm9vYE==" @=? Left "non-canonical encoding detected at offset: 5"
decode "Zm9vYK==" @=? Left "non-canonical encoding detected at offset: 5"
decode "Zm9vYA==" @=? Right "foo`"
, testCase "roundtrip for foob` ~ Zm9vYmA=" $ do
decode "Zm9vYmC=" @=? Left "non-canonical encoding detected at offset: 6"
decode "Zm9vYmD=" @=? Left "non-canonical encoding detected at offset: 6"
decode "Zm9vYmA=" @=? Right "foob`"
]
-- | Unit test trees for the `decode*With` family of text-valued functions
--
decodeWithVectors
:: ( IsString a
, IsString t
, Eq t
, Show e
, Show t
)
=> (a -> Either e t)
-- ^ utf8
-> TextHarness a t
-- ^ witness to the bytestring-ey dictionaries
-> Harness a
-- ^ witness to the text dictionaries
-> Harness t
-> TestTree
decodeWithVectors utf8 TextHarness{..} h t = testGroup "DecodeWith* unit tests"
[ testGroup "decodeWith negative tests"
[ testCase "decodeWith non-utf8 inputs on decodeUtf8" $ do
case decodeWith_ utf8 "\1079743" of
Left (DecodeError _) -> return ()
_ -> assertFailure "decoding phase"
, testCase "decodeWith valid utf8 inputs on decodeUtf8" $ do
case decodeWith_ utf8 (extractBase64 $ encode h "\1079743") of
Left (ConversionError _) -> return ()
_ -> assertFailure "conversion phase"
, testCase "decodeUrlWith non-utf8 inputs on decodeUtf8" $ do
case decodeUrlWith_ utf8 "\1079743" of
Left (DecodeError _) -> return ()
_ -> assertFailure "decoding phase"
, testCase "decodeUrlWith valid utf8 inputs on decodeUtf8" $ do
case decodeUrlWith_ utf8 (extractBase64 $ encodeUrl h "\1079743") of
Left (ConversionError _) -> return ()
_ -> assertFailure "conversion phase"
, testCase "decodeUrlPaddedWith non-utf8 inputs on decodeUtf8" $ do
case decodeUrlPaddedWith_ utf8 "\1079743" of
Left (DecodeError _) -> return ()
_ -> assertFailure "decoding phase"
, testCase "decodePaddedWith valid utf8 inputs on decodeUtf8" $ do
case decodeUrlPaddedWith_ utf8 (extractBase64 $ encodeUrl h "\1079743") of
Left (ConversionError _) -> return ()
_ -> assertFailure "conversion phase"
, testCase "decodeUnpaddedWith non-utf8 inputs on decodeUtf8" $ do
case decodeUrlUnpaddedWith_ utf8 "\1079743" of
Left (DecodeError _) -> return ()
_ -> assertFailure "decoding phase"
, testCase "decodeUnpaddedWith valid utf8 inputs on decodeUtf8" $ do
case decodeUrlUnpaddedWith_ utf8 (extractBase64 $ encodeUrlNopad h "\1079743") of
Left (ConversionError _) -> return ()
_ -> assertFailure "conversion phase"
]
, testGroup "decodeWith positive tests"
[ testCase "decodeWith utf8 inputs on decodeUtf8" $ do
a <- either (assertFailure . show) pure $ decode t "Zm9vYmFy"
b <- either (assertFailure . show) pure $ decodeWith_ utf8 "Zm9vYmFy"
a @=? b
, testCase "decodeUrlWith utf8 inputs on decodeUtf8" $ do
a <- either (assertFailure . show) pure $ decodeUrl t "PDw_Pz4-"
b <- either (assertFailure . show) pure $ decodeUrlWith_ utf8 "PDw_Pz4-"
a @=? b
, testCase "decodeUrlPaddedWith utf8 inputs on decodeUtf8" $ do
a <- either (assertFailure . show) pure $ decodeUrlPad t "PDw_Pz4-"
b <- either (assertFailure . show) pure $ decodeUrlPaddedWith_ utf8 "PDw_Pz4-"
a @=? b
, testCase "decodeUrlUnpaddedWith utf8 inputs on decodeUtf8" $ do
a <- either (assertFailure . show) pure $ decodeUrlNopad t "PDw_Pz4-"
b <- either (assertFailure . show) pure $ decodeUrlUnpaddedWith_ utf8 "PDw_Pz4-"
a @=? b
]
]