png-parser-bench.hs

--
-- Benchmark results at the bottom
--

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Criterion.Main
import qualified Data.Attoparsec.ByteString as Atto
import Data.Binary.Get
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as Bl
import Data.Digest.CRC32
import Data.Word


attoPngP :: Atto.Parser ()
attoPngP = do
    Atto.string pngMagic
    chunkP $ \len t -> guard (t == "IHDR" && len == 13)
    Atto.skipMany . chunkP $ \_ t ->
        guard (t /= "IHDR" && t /= "IEND")
    chunkP $ \len t -> guard (t == "IEND" && len == 0)
    Atto.endOfInput

    where
    w32be :: Atto.Parser Word32
    w32be =
        (\ws ->
             shiftL (fromIntegral (B.head ws)) 24 .|.
             shiftL (fromIntegral (B.index ws 1)) 16 .|.
             shiftL (fromIntegral (B.index ws 2)) 8 .|.
             fromIntegral (B.index ws 3))
        <$> Atto.take 4

    chunkP p = do
        len <- w32be
        typDat <- Atto.take (fromIntegral len + 4)
        p len (B.take 4 typDat)
        crc <- w32be
        guard (crc32 typDat == crc)


binaryPngP :: Get ()
binaryPngP = do
    getByteString 8 >>= guard . (==) pngMagic
    chunkP $ \len t -> guard (t == "IHDR" && len == 13)
    Atto.skipMany . chunkP $ \_ t ->
        guard (t /= "IHDR" && t /= "IEND")
    chunkP $ \len t -> guard (t == "IEND" && len == 0)
    isEmpty >>= guard

    where
    chunkP p = do
        len <- getWord32be
        typDat <- getByteString (fromIntegral len + 4)
        p len (B.take 4 typDat)
        crc <- getWord32be
        guard (crc32 typDat == crc)


pngMagic :: ByteString
pngMagic = "\x89PNG\r\n\x1A\n"


rawPngP :: ByteString -> Bool
rawPngP str0 =
    maybe False (const True)
          (evalState (runMaybeT begin) str0)

    where
    string n = do
        str <- state (B.splitAt n)
        str <$ guard (B.length str == n)

    tryP p = MaybeT . state $ \xs' -> do
        case runState (runMaybeT p) xs' of
          (Just x, xs) -> (Just x, xs)
          (Nothing, _) -> (Nothing, xs')

    w32be :: MaybeT (State ByteString) Word32
    w32be =
        (\ws ->
             shiftL (fromIntegral (B.head ws)) 24 .|.
             shiftL (fromIntegral (B.index ws 1)) 16 .|.
             shiftL (fromIntegral (B.index ws 2)) 8 .|.
             fromIntegral (B.index ws 3))
        <$> string 4

    begin = do
        tryP $ string 8 >>= guard . (==) pngMagic
        chunkP $ \len t -> guard (t == "IHDR" && len == 13)
        Atto.skipMany . chunkP $ \_ t ->
            guard (t /= "IHDR" && t /= "IEND")
        chunkP $ \len t -> guard (t == "IEND" && len == 0)
        gets B.null >>= guard

    chunkP p = tryP $ do
        len <- w32be
        typDat <- string (fromIntegral len + 4)
        p len (B.take 4 typDat)
        crc <- w32be
        guard (crc32 typDat == crc)


main :: IO ()
main = do
    pngCrypt <- B.readFile "pnghack-crypt.png"
    pngPlain <- B.readFile "pnghack-plain.png"

    let pngCryptL = Bl.fromStrict pngCrypt
        pngPlainL = Bl.fromStrict pngPlain

    let attoBench =
            bench "crypt" (whnf (Atto.parseOnly attoPngP) pngCrypt) :
            bench "plain" (whnf (Atto.parseOnly attoPngP) pngPlain) :
            []

        binaryBench =
            bench "crypt" (whnf (runGetOrFail binaryPngP) pngCryptL) :
            bench "plain" (whnf (runGetOrFail binaryPngP) pngPlainL) :
            []

        rawBench =
            bench "crypt" (whnf rawPngP pngCrypt) :
            bench "plain" (whnf rawPngP pngPlain) :
            []

    defaultMain $
        bgroup "atto" attoBench :
        bgroup "binary" binaryBench :
        bgroup "raw" rawBench :
        []

{-
Benchmark results (i5-7200U)
============================

benchmarking atto/crypt
time                 39.48 ns   (39.25 ns .. 39.79 ns)
                     0.999 R²   (0.997 R² .. 1.000 R²)
mean                 39.56 ns   (39.31 ns .. 40.07 ns)
std dev              1.160 ns   (678.9 ps .. 2.056 ns)
variance introduced by outliers: 47% (moderately inflated)

benchmarking atto/plain
time                 459.9 μs   (458.6 μs .. 461.2 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 457.9 μs   (457.3 μs .. 459.2 μs)
std dev              2.943 μs   (1.683 μs .. 5.193 μs)

benchmarking binary/crypt
time                 110.0 ns   (109.4 ns .. 110.7 ns)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 110.2 ns   (109.5 ns .. 111.4 ns)
std dev              3.058 ns   (1.626 ns .. 4.841 ns)
variance introduced by outliers: 42% (moderately inflated)

benchmarking binary/plain
time                 456.3 μs   (455.5 μs .. 457.5 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 456.0 μs   (455.1 μs .. 457.0 μs)
std dev              3.096 μs   (2.416 μs .. 3.936 μs)

benchmarking raw/crypt
time                 20.85 ns   (20.76 ns .. 21.00 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 20.96 ns   (20.86 ns .. 21.14 ns)
std dev              441.8 ps   (344.9 ps .. 639.1 ps)
variance introduced by outliers: 32% (moderately inflated)

benchmarking raw/plain
time                 456.4 μs   (455.7 μs .. 457.2 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 455.4 μs   (454.8 μs .. 456.8 μs)
std dev              3.029 μs   (1.796 μs .. 5.580 μs)
-}