Implemented TH splices for validated ByteString literals

    thLiteral    :: Quote m => String -> Code m ByteString
    thHexLiteral :: Quote m => String -> Code m ByteString

The former rejects inputs with non-octet code points above 0xFF.
The latter rejects odd-length inputs or inputs with characters
other than non-hexadecimal digits.

Author: hs-viktor

Changelog.md

@@ -4,6 +4,10 @@
   * [`Data.Data.dataTypeOf` for `StrictByteString` and `LazyByteString` now returns a `DataType` that uses `AlgRep` instead of `NoRep`.](https://github.com/haskell/bytestring/pull/614)
     * This allows utilities like `syb:Data.Generics.Text.gread` to be meaningfully used at these types containing `ByteString`s.
   * [`fromListN` in `instance IsList ByteString` truncates input list if it's longer than the size hint](https://github.com/haskell/bytestring/pull/672)
+* API additions
+  * New TH splices: `Data.ByteString.thLiteral` and `Data.ByteString.thHexLiteral`
+    * These validate input strings prior to generating corresponding
+      compile-time literal ByteStrings.
 <!--
 * Bug fixes:
 * API additions and behavior changes:

Data/ByteString.hs

@@ -67,6 +67,8 @@ module Data.ByteString (
         toStrict,
         fromFilePath,
         toFilePath,
+        thLiteral,
+        thHexLiteral,
 
         -- * Basic interface
         cons,

Data/ByteString/Internal/Type.hs

@@ -42,6 +42,7 @@ module Data.ByteString.Internal.Type (
         unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict,
         unsafePackAddress, unsafePackLenAddress,
         unsafePackLiteral, unsafePackLenLiteral,
+        thLiteral, thHexLiteral,
 
         -- * Low level imperative construction
         empty,
@@ -152,8 +153,9 @@ import Data.String              (IsString(..))
 
 import Control.Exception        (assert, throw, Exception)
 
-import Data.Bits                ((.&.))
+import Data.Bits                ((.|.), (.&.), complement, shiftL)
 import Data.Char                (ord)
+import Data.Foldable            (foldr')
 import Data.Word
 
 import Data.Data                (Data(..), mkConstr, mkDataType, Constr, DataType, Fixity(Prefix), constrIndex)
@@ -530,6 +532,98 @@ packUptoLenChars len cs0 =
           go !p (c:cs)          = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs
       in go p0 cs0
 
+data S2W = Octets {-# UNPACK #-} !Int [Word8]
+         | Hichar {-# UNPACK #-} !Int {-# UNPACK #-} !Word
+
+-- | Template Haskell splice to convert string constants to compile-time
+-- ByteString literals.  Unlike the 'IsString' instance, the input string
+-- is validated to ensure that each character is a valid /octet/, i.e. is
+-- at most @0xFF@ (255).
+--
+-- Example:
+--
+-- > :set -XTemplateHaskell
+-- > ehloCmd :: ByteString
+-- > ehloCmd = $$(thLiteral "EHLO")
+--
+#if MIN_VERSION_template_haskell(2,17,0)
+liftTyped :: forall a m. (TH.Lift a, TH.Quote m) => a -> TH.Code m a
+liftTyped = TH.liftTyped
+
+liftCode :: forall a m. m (TH.TExp a) -> TH.Code m a
+liftCode = TH.liftCode
+
+thLiteral :: (MonadFail m, TH.Quote m) => String -> TH.Code m ByteString
+#else
+liftTyped :: forall a. TH.Lift a => a -> TH.Q (TH.TExp a)
+liftTyped = TH.unsafeTExpCoerce . TH.lift
+
+liftCode :: forall a. TH.Q TH.Exp -> TH.Q (TH.TExp a)
+liftCode = TH.unsafeTExpCoerce
+
+thLiteral :: String -> TH.Q (TH.TExp ByteString)
+#endif
+thLiteral "" = [||empty||]
+thLiteral s = case foldr' op (Octets 0 []) s of
+    Octets !n ws -> liftTyped (unsafePackLenBytes n ws)
+    Hichar !i !w -> liftCode $ fail $ "non-octet character '\\" ++
+        show w ++ "' at offset: " ++ show i
+  where
+    op _ (Hichar !i !w) = Hichar (i + 1) w
+    op (fromIntegral . fromEnum -> !w) (Octets !i ws)
+        | w <= 0xff = Octets (i + 1) (fromIntegral w : ws)
+        | otherwise = Hichar 0 w
+
+data H2W = Hex {-# UNPACK #-} !Int [Word8]
+         | Odd {-# UNPACK #-} !Int {-# UNPACK #-} !Word [Word8]
+         | Bad {-# UNPACK #-} !Int {-# UNPACK #-} !Word
+
+-- | Template Haskell splice to convert hex-encoded string constants to compile-time
+-- ByteString literals.  The input string is validated to ensure that it consists of
+-- of an even number of valid hexadecimal digits (case insensitive).
+--
+-- Example:
+--
+-- > :set -XTemplateHaskell
+-- > ehloCmd :: ByteString
+-- > ehloCmd = $$(thLiteral "45484c4F")
+--
+#if MIN_VERSION_template_haskell(2,17,0)
+thHexLiteral :: (MonadFail m, TH.Quote m) => String -> TH.Code m ByteString
+#else
+thHexLiteral :: String -> TH.Q (TH.TExp ByteString)
+#endif
+thHexLiteral "" = [||empty||]
+thHexLiteral s =
+    case foldr' op (Hex 0 []) s of
+        (Hex n ws)  -> liftTyped (unsafePackLenBytes n ws)
+        (Odd i _ _) -> liftCode $ fail $ "Odd input length: " ++ show (1 + 2 * i)
+        (Bad i w)   -> liftCode $ fail $ "Non-hexadecimal character '\\" ++
+            show w ++ "' at offset: " ++ show i
+  where
+    -- Convert char to decimal digit value if result in [0, 9].
+    -- Otherwise, for hex digits, it remains to:
+    --   - fold upper and lower case by masking 0x20,
+    --   - subtract another 0x11 (0x41 total),
+    --   - check that result in [0,5]
+    --   - add 0xa
+    --
+    c2d :: Char -> Word
+    c2d c = fromIntegral (fromEnum c) - 0x30
+
+    op (c2d -> d) acc
+        | d <= 9 = case acc of
+            Hex i ws    -> Odd i d ws
+            Odd i lo ws -> Hex (i+1) $ fromIntegral ((d `shiftL` 4 .|. lo)) : ws
+            Bad i w     -> Bad (i + 1) w
+        | l <- (d .&. complement 0x20) - 0x11
+        , l <= 5
+        , x <- l + 0xa = case acc of
+            Hex i ws    -> Odd i (l + 0xa) ws
+            Odd i lo ws -> Hex (i+ 1) $ fromIntegral (x `shiftL` 4 .|. lo) : ws
+            Bad i w     -> Bad (i + 1) w
+        | otherwise = Bad 0 (d + 0x30)
+
 -- Unpacking bytestrings into lists efficiently is a tradeoff: on the one hand
 -- we would like to write a tight loop that just blasts the list into memory, on
 -- the other hand we want it to be unpacked lazily so we don't end up with a

tests/Lift.hs

@@ -31,6 +31,14 @@ testSuite = testGroup "Lift"
         let bs = "\0\1\2\3\0\1\2\3" :: BS.ByteString in
         bs === $$(TH.liftTyped $ BS.pack [0,1,2,3,0,1,2,3])
 #endif
+
+    , testProperty "thLiteral" $
+        let bs = "EHLO" :: BS.ByteString in
+        bs === $$(BS.thLiteral "EHLO")
+
+    , testProperty "thHexLiteral" $
+        let bs = "EHLO" :: BS.ByteString in
+        bs === $$(BS.thHexLiteral "45484c4F")
     ]
 
   , testGroup "lazy"