URIFragment.hs

{- |
Module:      JSONSchema.URIFragment
Copyright:   (c) DPella AB 2025
License:     LicenseRef-AllRightsReserved
Maintainer:  <matti@dpella.io>, <lobo@dpella.io>

UTF-8 percent encoding and decoding for URI fragments.
-}
module JSONSchema.URIFragment (
    encodeURIFragment,
    decodeURIFragment,
) where

import Data.ByteString qualified as BS
import Data.Char (ord)
import Data.Text (Text)
import Data.Text.Encoding qualified as TE
import Data.Word (Word8)

-- | Percent-encode bytes that are not legal in an RFC 3986 URI fragment.
encodeURIFragment :: Text -> Text
encodeURIFragment = TE.decodeLatin1 . BS.concatMap encodeByte . TE.encodeUtf8
  where
    encodeByte byte
        | isFragmentByte byte = BS.singleton byte
        | otherwise = BS.pack [percent, hexDigit (byte `div` 16), hexDigit (byte `mod` 16)]

-- | Percent-decode a URI fragment and require the result to be valid UTF-8.
decodeURIFragment :: Text -> Maybe Text
decodeURIFragment fragment = do
    bytes <- decodeBytes (BS.unpack (TE.encodeUtf8 fragment))
    either (const Nothing) Just (TE.decodeUtf8' (BS.pack bytes))
  where
    decodeBytes [] = Just []
    decodeBytes (byte : rest)
        | byte /= percent = (byte :) <$> decodeBytes rest
    decodeBytes (_ : high : low : rest) = do
        highNibble <- hexValue high
        lowNibble <- hexValue low
        ((highNibble * 16 + lowNibble) :) <$> decodeBytes rest
    decodeBytes _ = Nothing

-- RFC 3986: fragment = *(pchar / "/" / "?").
isFragmentByte :: Word8 -> Bool
isFragmentByte byte =
    isAsciiAlphaNumeric byte
        || byte `elem` map (fromIntegral . ord) ("-._~!$&'()*+,;=:@/?" :: String)

isAsciiAlphaNumeric :: Word8 -> Bool
isAsciiAlphaNumeric byte =
    (byte >= ascii 'a' && byte <= ascii 'z')
        || (byte >= ascii 'A' && byte <= ascii 'Z')
        || (byte >= ascii '0' && byte <= ascii '9')

hexDigit :: Word8 -> Word8
hexDigit nibble
    | nibble < 10 = ascii '0' + nibble
    | otherwise = ascii 'A' + nibble - 10

hexValue :: Word8 -> Maybe Word8
hexValue byte
    | byte >= ascii '0' && byte <= ascii '9' = Just (byte - ascii '0')
    | byte >= ascii 'A' && byte <= ascii 'F' = Just (byte - ascii 'A' + 10)
    | byte >= ascii 'a' && byte <= ascii 'f' = Just (byte - ascii 'a' + 10)
    | otherwise = Nothing

ascii :: Char -> Word8
ascii = fromIntegral . ord

percent :: Word8
percent = ascii '%'