HashCash Algorithm header generation in Haskell

Question

A thought exercise on my part as I'm relatively new to Haskell. I wanted an interesting project to work on so I decided to implement the Hashcash Algorithm, which is most commonly used as the basis of Bitcoin Proof of Work scheme. I am implementing the original specification that utilizes SHA1 and the description of the algorithmic steps are described well in the above Wikipedia article.

This appears to function correctly to the best of my knowledge, however I feel it is somewhat slower than it should be. Any potential suggestions for performance improvements are welcome here. Furthermore, as I am new to writing Haskell, if I am violating common expected conventions here then please feel free to point out how I can write more readable and standard code here.

{-# LANGUAGE BangPatterns #-}

module HashCash where

import Data.Int
import Data.List
import Data.List.Split (splitOn)
import Data.Char
import Data.Function
import System.Random
import Data.Bits
import Data.Either
import Data.Binary.Strict.Get
import System.IO as SIO
import Data.Word (Word32)
import Data.ByteString as B
import Data.ByteString.Char8 as BC
import Data.ByteString.UTF8 as BU
import Data.ByteString.Base64 as B64
import Data.ByteString.Conversion as BCON
import Data.ByteArray as BA
import Crypto.Random
import Crypto.Hash


startingCounter :: Int32
startingCounter = 1
difficulty :: Int
difficulty = 20
headerPrefix = "X-Hashcash: "
template = "1:{:{:{::{:{"
dateTemplate = "YYMMDDhhmmss"
address = "a@a"

-- example date because I dont want to mess with date formatting just now
exampleDate = "150320112233"

convertToString :: ByteString -> String
convertToString b = BU.toString b

convertFromString :: String -> ByteString
convertFromString s = BU.fromString s

convertIntToString :: Int -> String
convertIntToString a = convertToString . BCON.toByteString' $ a

encodeInt32 :: Int32 -> ByteString
encodeInt32 a = B64.encode . BCON.toByteString' $ a

mahDecoder :: Get Word32
mahDecoder = do
  first32Bits <- getWord32be
  return first32Bits

firstBitsZero :: (Bits a) => a -> Bool
firstBitsZero val = Data.List.foldr (\x acc -> ((not $ testBit val x) && acc)) True [0..(difficulty - 1)]

formatTemplate :: String -> [String] -> String
formatTemplate base [] = base
formatTemplate base (x:xs) = 
   let splix = (Data.List.Split.splitOn "{" base) :: [String]
       splixHead = Data.List.head splix ++ x
       splixTail = Data.List.tail splix
       concatSplitTail = Data.List.init $ Data.List.concatMap (++ "{") splixTail
   in formatTemplate (splixHead ++ concatSplitTail) xs

get16RandomBytes :: (DRG g) => g -> IO (ByteString, g)
get16RandomBytes gen = do
  let a = randomBytesGenerate 16 gen
  return $ a

getBaseString :: ByteString -> Int32 -> String
getBaseString bs counter = 
  let encodedVal = B64.encode bs
      encodedCounter = encodeInt32 counter
      baseParams = [(convertIntToString difficulty), exampleDate, address, (convertToString encodedVal), (convertToString encodedCounter)]
  in formatTemplate template baseParams

hashSHA1Encoded :: ByteString -> ByteString
hashSHA1Encoded bs =
  let hashDigest = hash bs :: Digest SHA1
      byteString = B.pack . BA.unpack $ hashDigest
  in byteString

-- Pass a counter and if the first 20 bits are zero then return the same counter value else increment it
-- signifying it is time to test the next number (NOTE: recursive style, may overflow stack)
testCounter :: ByteString -> Int32 -> Int32
testCounter rb !counter = 
  let baseString = getBaseString rb counter
      hashedString = hashSHA1Encoded $ convertFromString baseString
      !eitherFirst32 = runGet mahDecoder hashedString
      incCounter = counter + 1
  in case eitherFirst32 of
    (Left first32, _) -> testCounter rb incCounter
    (Right first32, _) -> if (firstBitsZero first32)
                           then counter
                           else testCounter rb incCounter

testCounterBool :: ByteString -> Int32 -> Bool
testCounterBool rb counter =
  let baseString = getBaseString rb counter
      hashedString = hashSHA1Encoded $ convertFromString baseString
      eitherFirst32 = runGet mahDecoder hashedString
  in case eitherFirst32 of
    (Left first32, _) -> False
    (Right first32, _) -> firstBitsZero first32

-- Keep taking incrementing counters from an infinite list and testing them until we find a counter 
-- that generates a valid header
findValidCounter :: ByteString -> Int32
findValidCounter ran = Data.List.last $ Data.List.takeWhile (not . testCounterBool ran) [1..]

generateHeader :: IO String
generateHeader = do
  g <- getSystemDRG
  (ran, _) <- get16RandomBytes g
  let validCounter = findValidCounter ran
  let validHeader = getBaseString ran validCounter
  return $ headerPrefix ++ validHeader

main :: IO ()
main = do 
  header <- generateHeader
  SIO.putStrLn header
  return ()

Answer 1

That's a lot of imports, and several seem strange. For example Data.List, since you only use head, tail, foldr or other Prelude functions. The problem is that you've use as, but left the qualified. This should be:

import           Crypto.Hash
import           Crypto.Random
import           Data.Binary.Strict.Get
import           Data.Bits
import           Data.ByteString (ByteString)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Conversion as BCON
import qualified Data.ByteString.UTF8 as BU
import           Data.Either (either)
import           Data.Int (Int32)
import           Data.List.Split (splitOn)
import           Data.Word (Word32)
import           System.Random

qualified will prevent names like head from Data.ByteString getting imported into the global namespace. See "import" for more information. The whitespace is purely custom. I like to sort the modules by name, but that's up to you.

Next, I would make clear that your convert* functions are only new names, e.g.:

convertToString :: ByteString -> String
convertToString = BU.toString

convertFromString :: String -> ByteString
convertFromString = BU.fromString

convertIntToString :: Int -> String
convertIntToString = convertToString . BCON.toByteString' 

encodeInt32 :: Int32 -> ByteString
encodeInt32 = B64.encode . BCON.toByteString' 

mahDecoder :: Get Word32
mahDecoder = getWord32be

The mahDecoder change is a little bit different, since you've used originally something like

foo = do
  x <- func
  return x

However, this is fine due to the right-identity monad law:

func >>= return === func

Next, firstBitsZero can be rewritten using all:

firstBitsZero :: (Bits a) => a -> Bool
firstBitsZero val = all (\x -> not $ testBit val x) [0..(difficulty - 1)]

Note that a bit mask would be faster would make it faster, e.g.:

bitMask :: Num a => a
bitMask = (2 ^ difficulty) - 1

firstBitsZero :: Int32 -> Bool    
firstBitsZero val = bitMask .&. val == zeroBits

That way you only have to create the mask once and then only use bitwise AND, which usually gets compiled into a single CPU instruction.

When working with list, you want to add elements at the front, not at the back. Instead of

init (concatMap (++ "{") splixTail)

you should use

tail (concatMap ('{' :) splixTail)

The problem is that ++ is linear in its first argument:

(x:xs) ++ ys = x : (xs ++ ys)

(:) on the other hand is constant in terms of time.

We end up with:

formatTemplate :: String -> [String] -> String
formatTemplate base [] = base
formatTemplate base (x:xs) = 
   let (splixHead:splixTail) = splitOn "{" base
       concatSplitTail       = tail $ concatMap ("{" :) splixTail
   in formatTemplate (splixHead ++ (x : concatSplitTail)) xs

Your next function doesn't need to be in IO:

get16RandomBytes :: (DRG g) => g -> (ByteString, g)
get16RandomBytes = randomBytesGenerate 16 

In your following functions, I would prefer to use where, but that's completely up to personal preference. Also, if you use an expression only once, it might make sense to get rid of its binding if the code stays readable:

hashSHA1Encoded :: ByteString -> ByteString
hashSHA1Encoded bs = B.pack . BA.unpack $ (hash bs :: Digest SHA1)

or

hashSHA1Encoded :: ByteString -> ByteString
hashSHA1Encoded bs = B.pack . BA.unpack $ hashDigest
  where
    hashDigest = hash bs :: Digest SHA1

Both testCounter and testCounterBool use some duplicate code, which should be placed in its own function:

decodeFirst32 :: ByteString -> Int32 -> Either String Word32
decodeFirst32 rb = fst . runGet mahDecoder . hashSHA1Encoded . convertFromString . getBaseString rb

This makes testCounter and testCounterBool a lot simpler:

testCounter :: ByteString -> Int32 -> Int32
testCounter rb !counter = 
  case decodeFirst32 rb counter of
    Right f32 | firstBitsZero f32 -> counter
    _                             -> testCounter rb (counter + 1)

testCounterBool :: ByteString -> Int32 -> Bool
testCounterBool rb counter = either (const False) firstBitsZero $ decodeFirst32 rb counter

With findValidCounter, I'm somewhat sure that your logic isn't 100% correct. According to the documentation, you check with increasing counters, but last . takeWhile p will take the last element for which p holds. Since p = not . testCounterBool ran, you will end up with the last element for which testCounterBool ran does not hold.

Either way, if you look for the first element that holds a predicate, you can use find from Data.List instead:

findValidCounter ran = fromJust $ find (testCounterBool ran) [1..]    

Given the changes with get16RandomBytes, we end up with

generateHeader :: IO String
generateHeader = do
  (ran, _) <- fmap get16RandomBytes getSystemDRG
  let validCounter = findValidCounter ran
  let validHeader = getBaseString ran validCounter
  return $ headerPrefix ++ validHeader