willow-0.1.0.0: test/Test/Willow/Property/Encoding/GB.hs

{-|
Description:    

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

Stability:      experimental
Portability:    portable
-}
module Test.Willow.Property.Encoding.GB
    ( tests
    ) where


import qualified Hedgehog as H
import qualified Hedgehog.Gen as H.G
import qualified Hedgehog.Range as H.R

import Web.Willow.Common.Encoding

import Test.Willow.Property.Common


tests :: H.Group
tests = packGroup "Web.Willow.Common.Encoding.GB"
    -- Single byte tests handled in "unit" due to limited number
    [ decodeEndOfStream
    , decodeTwoByteInvalid
    , decodeThreeByteInvalid
    , decodeFourByteInvalid
    , decodeOneByteLookup
    , decodeTwoByteLookup
    , decodeFourByteLookup
    ]


decodeEndOfStream :: Test
decodeEndOfStream = packTest "incomplete character" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    first <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    second <- H.forAll . H.G.word8 $ H.R.linear 0x30 0x39
    third <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    checkEndOfStream enc [first, second, third]


decodeTwoByteInvalid :: Test
decodeTwoByteInvalid = packTest "invalid second byte" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    first <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    second <- H.forAll $ H.G.choice
        [ H.G.word8 $ H.R.linear 0x00 0x2F
        , H.G.word8 $ H.R.linear 0x3A 0xFE
        , H.G.constant 0xFF
        ]
    let check = if second <= 0x7F
            then checkInvalid
            else checkInvalidAll
    check enc [first, second]

decodeThreeByteInvalid :: Test
decodeThreeByteInvalid = packTest "invalid third byte" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    first <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    second <- H.forAll . H.G.word8 $ H.R.linear 0x30 0x39
    third <- H.forAll $ H.G.choice
        [ H.G.word8 $ H.R.linear 0x00 0x80
        , H.G.constant 0xFF
        ]
    checkInvalid enc [first, second, third]

decodeFourByteInvalid :: Test
decodeFourByteInvalid = packTest "invalid fourth byte" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    first <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    second <- H.forAll . H.G.word8 $ H.R.linear 0x30 0x39
    third <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    fourth <- H.forAll $ H.G.choice
        [ H.G.word8 $ H.R.linear 0x00 0x2F
        , H.G.word8 $ H.R.linear 0x3A 0xFE
        , H.G.constant 0xFF
        ]
    checkInvalid enc [first, second, third, fourth]


decodeOneByteLookup :: Test
decodeOneByteLookup = packTest "one-byte sequence" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    first <- H.forAll $ H.G.choice
        [ H.G.word8 $ H.R.linear 0x00 0x80
        , H.G.constant 0xFF
        ]
    checkTrailing enc [first]

decodeTwoByteLookup :: Test
decodeTwoByteLookup = packTest "two-byte sequence" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    first <- H.forAll . H.G.word8 $ H.R.linear 0x81 0xFE
    second <- H.forAll . H.G.choice $ map H.G.word8
        [ H.R.linear 0x40 0x7E
        , H.R.linear 0x80 0xFE
        ]
    if second <= 0x7F
        then checkTrailing enc [first, second]
        else checkTrailingAll enc [first, second]

decodeFourByteLookup :: Test
decodeFourByteLookup = packTest "four-byte sequence" $ do
    enc <- H.forAll $ H.G.element [Gbk, Gb18030]
    (first, second, third, fourth) <- H.forAll $ H.G.choice
        [ do
            b1 <- H.G.word8 $ H.R.linear 0x81 0xFE
            b2 <- H.G.word8 $ H.R.linear 0x30 0x39
            b3 <- H.G.word8 $ H.R.linear 0x81 0xFE
            b4 <- H.G.word8 $ H.R.linear 0x30 0x39
            return (b1, b2, b3, b4)
        , do    -- null range between 39419 and 189000
            b1 <- H.G.word8 $ H.R.linear 0x84 0xE9
            let (l2, h2) = case b1 of
                    0x84 -> (0x31, 0x39)
                    _ -> (0x30, 0x39)
            b2 <- H.G.word8 $ H.R.linear l2 h2
            let l3 = case (b1, b2) of
                    (0x84, 0x31) -> 0xA4
                    _ -> 0x81
            b3 <- H.G.word8 $ H.R.linear l3 0xFE
            let (l4, h4) = case (b1, b2, b3) of
                    (0x84, 0x31, 0xA4) -> (0x39, 0x39)
                    (0xE9, 0x39, 0xFE) -> (0x30, 0x38)
                    _ -> (0x30, 0x39)
            b4 <- H.G.word8 $ H.R.linear l4 h4
            return (b1, b2, b3, b4)
        , do    -- null range above 1237575
            b1 <- H.G.word8 $ H.R.linear 0xE3 0xFE
            let l2 = case b1 of
                    0xE3 -> 0x32
                    _ -> 0x30
            b2 <- H.G.word8 $ H.R.linear l2 0x39
            let l3 = case (b1, b2) of
                    (0xE3, 0x32) -> 0x9A
                    _ -> 0x81
            b3 <- H.G.word8 $ H.R.linear l3 0xFE
            let l4 = case (b1, b2, b3) of
                    (0xE3, 0x32, 0x9A) -> 0x36
                    _ -> 0x30
            b4 <- H.G.word8 $ H.R.linear l4 0x39
            return (b1, b2, b3, b4)
        ]
    checkTrailingAll enc [first, second, third, fourth]