cryptonite-0.25: tests/StressHash.hs

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
module Main where

import Data.Proxy
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Monad
import GHC.Conc
import System.Environment
import Data.Monoid

import qualified Crypto.Hash as H
import qualified Data.ByteString as B

doHashRandom :: forall h . H.HashAlgorithm h
             => Proxy h         -- hash algorithm
             -> Chan (Int, Int) -- channel to report
             -> Int             -- thread id
             -> IO ()
doHashRandom _ chan !tid = loop 0
  where
    loop !i = do
        when (tid > 5) $ threadDelay 1200
        when ((i `mod` 1000) == 0) $ writeChan chan (tid, i)

        let lengthLimit n | n < 0     = 0
                          | n > 257   = n `mod` 257
                          | otherwise = n

        let i' = i `mod` (tid * 1500)
            (nbChunks,multi) = case i `mod` 4 of
                        0 -> (1, False)
                        1 -> (2, False)
                        2 -> (1, True)
                        3 -> (3, False)

        let dat = take nbChunks $ [B.replicate (lengthLimit i') 1, B.replicate (lengthLimit (i' + 10)) 2, B.replicate (lengthLimit (i' + 20)) 3]

        let h   = H.hashInit @ h
            h2  = H.hashUpdates h dat
            !digest = H.hashFinalize h2
            !digest2 = if multi then H.hash digest else digest
        digest2 `seq` loop (i+1)

main = do
    args <- getArgs
    let caps = numCapabilities
    putStrLn (show caps <> " capabilities")

    let n = 10

    let proxy = Proxy @ H.Blake2b_256

    s <- newChan
    mapM_ (forkIO . doHashRandom proxy s) (take n [1..])

    forever $ do
        (tid, progress) <- readChan s
        putStrLn ("thread " <> show tid <> " at " <> show progress)