packages feed

double-x-encoding (empty) → 1.1.0.0

raw patch · 3 files changed

+483/−0 lines, 3 filesdep +Cabal-syntaxdep +basedep +double-x-encoding

Dependencies added: Cabal-syntax, base, double-x-encoding, text

Files

+ double-x-encoding.cabal view
@@ -0,0 +1,61 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           double-x-encoding+version:        1.1.0.0+synopsis:       Encoding scheme to encode any Unicode string with only [0-9a-zA-Z_]+description:    Double-X-Encoding is an encoding scheme to encode any Unicode string+                with only characters from [0-9a-zA-Z_].+                Therefore it's quite similar to URL percent-encoding.+                It's especially useful for GraphQL ID generation,+                as it includes support for encoding leading digits and double underscores.+category:       Codec, Codecs, GraphQL, ASCII, Unicode, Encoding, Decoding+homepage:       https://github.com/Airsequel/double-x-encoding#readme+bug-reports:    https://github.com/Airsequel/double-x-encoding/issues+author:         Adrian Sieber+maintainer:     adrian@feram.io+license:        ISC+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/Airsequel/double-x-encoding+  subdir: Haskell++library+  exposed-modules:+    DoubleXEncoding+  other-modules:+    Paths_double_x_encoding+  hs-source-dirs:+    source+  default-extensions:+    LambdaCase+    MultiWayIf+    OverloadedStrings+  build-depends:+    Cabal-syntax >=3.10 && <3.12,+    base >=4.18 && <4.20,+    text >=2.0 && <2.2+  default-language: GHC2021++test-suite double-x-encoding-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+    Paths_double_x_encoding+  hs-source-dirs:+    tests+  default-extensions:+    LambdaCase+    MultiWayIf+    OverloadedStrings+  build-depends:+    Cabal-syntax >=3.10 && <3.12,+    base >=4.18 && <4.20,+    double-x-encoding,+    text >=2.0 && <2.2+  default-language: GHC2021
+ source/DoubleXEncoding.hs view
@@ -0,0 +1,313 @@+-- | Implementation of double-X-encoder and -decoder in Haskell+{- ORMOLU_DISABLE -}++module DoubleXEncoding where++import Data.Function ((&))+import qualified Data.Text as T+import Data.Text (replace, Text)+import Data.Functor ((<&>))+import Distribution.Utils.Generic (isAsciiAlphaNum)+import Numeric (showHex, readHex)+import Data.Char (ord, isDigit, chr)+import Control.Monad (join)+++-- | charEncode mapping in Haskell+charEncode :: Char -> Char+charEncode = \case+  ' ' -> '0'+  '!' -> '1'+  '"' -> '2'+  '#' -> '3'+  '$' -> '4'+  '%' -> '5'+  '&' -> '6'+  '\'' -> '7'+  '(' -> '8'+  ')' -> '9'+  '*' -> 'A'+  '+' -> 'B'+  ',' -> 'C'+  '-' -> 'D'+  '.' -> 'E'+  '/' -> 'F'++  ':' -> 'G'+  ';' -> 'H'+  '<' -> 'I'+  '=' -> 'J'+  '>' -> 'K'+  '?' -> 'L'+  '@' -> 'M'++  '[' -> 'N'+  '\\' -> 'O'+  ']' -> 'P'+  '^' -> 'Q'+  '_' -> 'R'+  '`' -> 'S'++  '{' -> 'T'+  '|' -> 'U'+  '}' -> 'V'+  '~' -> 'W'++  -- TODO: Remove this parsing workaround. Should be "X": "X"+  'X' -> 'x'++  -- '': 'Z',  -- Reserved for encoding digits++  _ -> '\0'+++charDecode :: Char -> Char+charDecode = \case+  '0' -> ' '+  '1' -> '!'+  '2' -> '"'+  '3' -> '#'+  '4' -> '$'+  '5' -> '%'+  '6' -> '&'+  '7' -> '\''+  '8' -> '('+  '9' -> ')'+  'A' -> '*'+  'B' -> '+'+  'C' -> ','+  'D' -> '-'+  'E' -> '.'+  'F' -> '/'++  'G' -> ':'+  'H' -> ';'+  'I' -> '<'+  'J' -> '='+  'K' -> '>'+  'L' -> '?'+  'M' -> '@'++  'N' -> '['+  'O' -> '\\'+  'P' -> ']'+  'Q' -> '^'+  'R' -> '_'+  'S' -> '`'++  'T' -> '{'+  'U' -> '|'+  'V' -> '}'+  'W' -> '~'++  -- TODO: Remove this parsing workaround. Should be "X": "X"+  'x' -> 'X'++  _ -> '\0'+++hexShiftEncode :: Char -> Char+hexShiftEncode = \case+  '0' -> 'a'+  '1' -> 'b'+  '2' -> 'c'+  '3' -> 'd'+  '4' -> 'e'+  '5' -> 'f'+  '6' -> 'g'+  '7' -> 'h'+  '8' -> 'i'+  '9' -> 'j'+  'a' -> 'k'+  'b' -> 'l'+  'c' -> 'm'+  'd' -> 'n'+  'e' -> 'o'+  'f' -> 'p'++  _ -> '\0'+++hexShiftDecode :: Char -> Char+hexShiftDecode = \case+  'a' -> '0'+  'b' -> '1'+  'c' -> '2'+  'd' -> '3'+  'e' -> '4'+  'f' -> '5'+  'g' -> '6'+  'h' -> '7'+  'i' -> '8'+  'j' -> '9'+  'k' -> 'a'+  'l' -> 'b'+  'm' -> 'c'+  'n' -> 'd'+  'o' -> 'e'+  'p' -> 'f'++  _ -> '\0'+++data EncodeOptions = EncodeOptions+  { encodeLeadingDigit :: Bool+  , encodeDoubleUnderscore :: Bool+  }+++doubleXEncodeWithOptions :: EncodeOptions -> Text -> Text+doubleXEncodeWithOptions encodeOptions text =+  let+    encodeStandard text = text+      & replace "XX" "XXXXXX"+      & (\txt ->+          if encodeOptions&encodeDoubleUnderscore+          then txt & replace "__" "XXRXXR"+          else txt+        )+      & T.unpack+      <&> (\char ->+            if isAsciiAlphaNum char || char == '_'+            then [char]+            else+              if charEncode char /= '\0'+              then ['X', 'X', charEncode char]+              else+                let+                  charHex = showHex (ord char) ""+                  charHexEncoded = charHex <&> hexShiftEncode+                  padStart n txt = replicate (n - length txt) 'a' ++ txt+                in+                  if+                    | length charHex <= 5 ->+                        "XX" ++ padStart 5 charHexEncoded+                    | length charHex == 6 ->+                        "XXY" ++ padStart 6 charHexEncoded+                    | otherwise ->+                        error "ERROR: Hex encoding is too long"+          )+      & join+      & T.pack++    encodeDigit digit =+      T.pack ['X', 'X', 'Z', digit]+  in+    if encodeOptions&encodeLeadingDigit+    then+      case T.unpack text of+        [] -> ""++        leadingChar : rest  ->+          if not $ isDigit leadingChar+          then encodeStandard text+          else+            if null rest+            then encodeDigit leadingChar+            else+              encodeDigit leadingChar+              <> doubleXEncodeWithOptions+                    encodeOptions { encodeLeadingDigit = False }+                    (T.pack rest)+    else+      encodeStandard text+++++defaultOptions :: EncodeOptions+defaultOptions = EncodeOptions+    { encodeLeadingDigit = False+    , encodeDoubleUnderscore = False+    }+++doubleXEncode :: Text -> Text+doubleXEncode =+    doubleXEncodeWithOptions defaultOptions+++gqlOptions :: EncodeOptions+gqlOptions = EncodeOptions+    { encodeLeadingDigit = True+    , encodeDoubleUnderscore = True+    }+++doubleXEncodeGql :: Text -> Text+doubleXEncodeGql =+    doubleXEncodeWithOptions gqlOptions+++parseHex :: Text -> Int+parseHex text =+  case readHex (T.unpack text) of+    [(int, "")] -> int+    _ -> 0+++doubleXDecode :: Text -> Text+doubleXDecode text =+  let+    decodeWord :: Text -> (Text, Text)+    decodeWord word =+      let+        noXX = T.drop 2 word+        first = T.take 1 noXX+      in+        if  | first >= "a" && first <= "p" ->+                (T.pack [+                    noXX+                      & T.unpack+                      & take 5+                      <&> hexShiftDecode+                      & T.pack+                      & parseHex+                      & chr+                  ]+                , T.drop 5 noXX+                )++            | first == "X" ->+                if "XXXX" `T.isPrefixOf` noXX+                then ("XX", T.drop 4 noXX)+                else ("X", T.drop 1 word)++            | first == "Y" ->+                (T.pack [+                    noXX+                      & T.drop 1  -- Remove the "Y"+                      & T.unpack+                      & take 6+                      <&> hexShiftDecode+                      & T.pack+                      & parseHex+                      & chr+                  ]+                , T.drop 7 noXX+                )++            | first == "Z" ->+                (noXX+                    & T.drop 1+                    & T.take 1+                , T.drop 2 noXX+                )++            | otherwise ->+              (noXX+                & T.take 1+                & T.unpack+                <&> charDecode+                & T.pack+              , T.drop 1 noXX+              )+  in+    text+      & T.breakOn "XX"+      & \case+          ("", end) -> case decodeWord end of+            (decoded, "") -> decoded+            (decoded, rest) -> decoded <> doubleXDecode rest+          (start, "") -> start+          (start, end) -> start <> doubleXDecode end
+ tests/Main.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++{- ORMOLU_DISABLE -}++module Main where++import Data.Function ((&))+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Functor ((<&>))+import Distribution.Utils.Generic (isAsciiAlphaNum)+import Numeric (showHex)+import Data.Char (ord, isDigit)+import Control.Monad (join)++import DoubleXEncoding+  (EncodeOptions(..), doubleXEncode, doubleXEncodeGql, doubleXDecode)+++main :: IO ()+main = do+  let+    getEncoderTest encoder a b = T.putStrLn $+      if encoder a /= b+      then+        "❌ ENCODE ERROR: "+        <> a <> " | " <> encoder a <> " /= " <> b+      else+        if doubleXDecode (encoder a) /= a+        then+          "❌ DECODE ERROR: "+          <> a <> " | " <> doubleXDecode (encoder a) <> " /= " <> a+        else+          "✅ " <> a <> ": " <> encoder a <> " == " <> b+++    expectEncode a b =+      getEncoderTest doubleXEncode a b++    expectEncodeGql a b =+      getEncoderTest doubleXEncodeGql a b++    expectDecode a b = T.putStrLn $+        if doubleXDecode a /= b+        then+            "❌ DECODE ERROR: "+            <> a <> " | " <> doubleXDecode a <> " /= " <> b+        else+            "✅ " <> a <> ": " <> doubleXDecode a <> " == " <> b++  expectEncode "camelCaseId" "camelCaseId"+  expectEncode "snake_case_id" "snake_case_id"+  expectEncode "__Schema" "__Schema"+  expectEncode "0test" "0test"+  expectEncode "doxxing" "doxxing"+  expectEncode "DOXXING" "DOXXXXXXING"+  expectEncode "XXX" "XXXXXXX"+  expectEncode ">XXX<" "XXKXXXXXXXXXI"+  expectEncode "id with spaces" "idXX0withXX0spaces"+  expectEncode "%" "XX5"+  expectEncode "id-with.special$chars!" "idXXDwithXXEspecialXX4charsXX1"+  expectEncode "id_with_ümläutß" "id_with_XXaaapmmlXXaaaoeutXXaaanp"+  expectEncode "Emoji: 😅" "EmojiXXGXX0XXbpgaf"+  expectEncode "Multi Byte Emoji: \x1f468\x200D\x1f9b2"+    "MultiXX0ByteXX0EmojiXXGXX0XXbpegiXXacaanXXbpjlc"+  -- Support characters from the Supplementary Private Use Area-B+  expectEncode "\x100000" "XXYbaaaaa"+  expectEncode "\x10FFFF" "XXYbapppp"++  expectEncodeGql "__Schema" "XXRXXRSchema"+  expectEncodeGql "also__middle" "alsoXXRXXRmiddle"+  expectEncodeGql "0test" "XXZ0test"+  expectDecode "alsoXXZ0middle" "also0middle"++  -- https://github.com/minimaxir/big-list-of-naughty-strings+  txtFile <- readFile "./tests/blns.txt"++  let+    blns = T.lines $ T.pack txtFile+    blnsFiltered = blns & filter+      (\line -> not (T.null line) && not (T.isPrefixOf "#" line))++    testEncodeDecode str =+      if str /= doubleXDecode (doubleXEncode str)+      then+        "❌ \""+        <> doubleXDecode (doubleXEncode str)+        <> "\" /= \""+        <> str+        <> "\""+      else "✅"++    testEncodeGqlDecode str =+      if str /= doubleXDecode (doubleXEncodeGql str)+      then+        "❌ \""+        <> doubleXDecode (doubleXEncodeGql str)+        <> "\" /= \""+        <> str+        <> "\""+      else "✅"++  T.putStrLn "\n\n============ ENCODE - DECODE ============"+  blnsFiltered <&> testEncodeDecode <&> T.putStr & sequence_++  T.putStrLn "\n\n========== ENCODE GQL - DECODE =========="+  blnsFiltered <&> testEncodeGqlDecode <&> T.putStr & sequence_++  pure ()