SingleByte.hs

{-|
Description:    Emulating tests from @encoding/single-byte-decoder.js@

Copyright:      (c) 2020 Samuel May
License:        MPL-2.0
Maintainer:     ag.eitilt@gmail.com

Stability:      experimental
Portability:    portable
-}
module Test.Willow.WebPlatformTests.Manual.Encoding.SingleByte
    ( tests
    ) where


import qualified Data.ByteString as BS
import qualified Data.Maybe as Y
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Read as T.R

import qualified Test.HUnit as U

import System.FilePath ( (</>), (<.>) )
import Test.HUnit ( (~:), (~?=), (@?) )

import Web.Willow.Common.Encoding
import Web.Willow.Common.Encoding.Labels

import Test.Willow.WebPlatformTests.Manual.CommonReader


tests :: IO U.Test
tests = do
    charsets' <- charsets
    return $ "single-byte-decoder.html" ~: U.TestList
        [ "decoded charset matches index" ~: U.TestList $ map expectedCharsetDecode charsets'
        , "encoded index is sane" ~: U.TestList $ map expectedCharsetEncode charsets'
        , "encode-decode index roundtrips" ~: U.TestList $ map roundtrip charsets'
        ]


charsets :: IO [(Encoding, [Maybe Char])]
charsets = do
    testFile <- dataFile $ "encoding" </> "single-byte-decoder" <.> "html"
    f <- T.readFile testFile
    let ls = filter (T.isPrefixOf $ T.pack "   \"") $ T.lines f
        is = map (T.split $ \c -> c == '[' || c == ']') ls
    return $ Y.mapMaybe (\l -> extract l >>= repack) is
  where extract (l:is:_) = Just (T.split (== '"') l !! 1, T.split (== ',') is)
        extract _ = Nothing
        toChar = either (const Nothing) (Just . toEnum . fst) . T.R.decimal
        repack (enc, index) = case lookupEncoding enc of
            Just enc' -> Just (enc', map Just ['\NUL'..'\DEL'] ++ map toChar index)
            Nothing -> Nothing

--TODO: This is also supposed to check all labels ('someEncodings').
expectedCharsetDecode :: (Encoding, [Maybe Char]) -> U.Test
expectedCharsetDecode (enc, index) = show enc ~:
    decodeEnc' enc (BS.pack [0x00..0xFF]) ~?= T.pack (map (Y.fromMaybe '\xFFFD') index)

--TODO: The below aren't actually part of the WPT; remove them once there's an
-- equivalent in Test.Willow.Unit.
expectedCharsetEncode :: (Encoding, [Maybe Char]) -> U.Test
expectedCharsetEncode (enc, index) = show enc ~: U.TestCase $ do
    let bs = encodeEnc' enc . T.pack $ Y.catMaybes index
    
    BS.length bs <= 0x100 @? "charset too long"
    -- This doesn't check the encoded values are correct, but it does at least
    -- make sure nothing's out of order.
    snd (BS.foldl' (\(c, b) c' -> (c', b && c < c')) (0x00, True) $ BS.drop 1 bs)
        @? "charset out of order"

roundtrip :: (Encoding, [Maybe Char]) -> U.Test
roundtrip (enc, index) = show enc ~:
    decodeEnc' enc (encodeEnc' enc index') ~?= index'
  where index' = T.pack $ Y.catMaybes index