From cc26ce8ce44a90ccdbe6e81602c821a97ad0ad9e Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Sat, 2 May 2015 05:40:14 +0100
Subject: [PATCH] fix hexadecimal string generation to be hopefully (much)
 safer.

---
 Crypto/Internal/Hex.hs    | 35 +++++++++++++++++++++++++++--------
 Crypto/Internal/Memory.hs |  2 +-
 2 files changed, 28 insertions(+), 9 deletions(-)

diff --git a/Crypto/Internal/Hex.hs b/Crypto/Internal/Hex.hs
index 323bea5..8c307bb 100644
--- a/Crypto/Internal/Hex.hs
+++ b/Crypto/Internal/Hex.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Rank2Types #-}
 module Crypto.Internal.Hex
     ( showHexadecimal
     , toHexadecimal
@@ -21,24 +22,42 @@ import Data.Word
 import GHC.Prim
 import GHC.Types
 import GHC.Word
+import Control.Monad
 import Foreign.Storable
 import Foreign.Ptr (Ptr)
 
-showHexadecimal :: Ptr Word8 -> Int -> String
-showHexadecimal ptr len = loop 0
+showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -> Int -> String
+showHexadecimal withPtr = doChunks 0
   where
-        loop i
-            | i == len  = []
+        doChunks ofs len
+            | len < 4   = doUnique ofs len
+            | otherwise = do
+                let !(W8# a, W8# b, W8# c, W8# d) = unsafeDoIO $ withPtr (read4 ofs)
+                    (# w1, w2 #) = convertByte a
+                    (# w3, w4 #) = convertByte b
+                    (# w5, w6 #) = convertByte c
+                    (# w7, w8 #) = convertByte d
+                 in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4
+                  : wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8
+                  : doChunks (ofs + 4) (len - 4)
+
+        doUnique ofs len
+            | len == 0  = []
             | otherwise =
-                let !(W8# b)     = byteIndex i
+                let !(W8# b)     = unsafeDoIO $ withPtr (byteIndex ofs)
                     (# w1, w2 #) = convertByte b
-                 in wToChar w1 : wToChar w2 : loop (i+1)
+                 in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1)
+
+        read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
+        read4 ofs p =
+            liftM4 (,,,) (byteIndex ofs     p) (byteIndex (ofs+1) p)
+                         (byteIndex (ofs+2) p) (byteIndex (ofs+3) p)
 
         wToChar :: Word# -> Char
         wToChar w = toEnum (I# (word2Int# w))
 
-        byteIndex :: Int -> Word8
-        byteIndex i = unsafeDoIO (peekByteOff ptr i)
+        byteIndex :: Int -> Ptr Word8 -> IO Word8
+        byteIndex i p = peekByteOff p i
 
 toHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
 toHexadecimal bout bin n = loop 0
diff --git a/Crypto/Internal/Memory.hs b/Crypto/Internal/Memory.hs
index c049c39..a4ae80e 100644
--- a/Crypto/Internal/Memory.hs
+++ b/Crypto/Internal/Memory.hs
@@ -123,5 +123,5 @@ bytesIndex (Bytes m) (I# i) = unsafeDoIO $ IO $ \s ->
 {-# NOINLINE bytesIndex #-}
 
 bytesShowHex :: Bytes -> String
-bytesShowHex b = unsafeDoIO $ withPtr b $ \p -> return $ showHexadecimal p (bytesLength b)
+bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b)
 {-# NOINLINE bytesShowHex #-}