├── Setup.hs ├── src └── Test │ └── QuickFuzz │ ├── Gen │ ├── Base │ │ ├── Unicode.hs │ │ ├── String.hs │ │ ├── ByteString.hs │ │ ├── Vector.hs │ │ ├── Value.hs │ │ ├── Image.hs │ │ ├── Time.hs │ │ └── Regex.hs │ ├── Media.hs │ ├── Bnfc.hs │ ├── Network.hs │ ├── Bnfc │ │ ├── .gitignore │ │ ├── Grammar.cf │ │ ├── AbsGrammar.hs │ │ ├── .travis.yml │ │ ├── Grammar.hs │ │ └── PrintGrammar.hs │ ├── Archive.hs │ ├── Pki.hs │ ├── Image.hs │ ├── Base.hs │ ├── Document.hs │ ├── Code.hs │ ├── Media │ │ └── Wav.hs │ ├── Document │ │ ├── PS.hs │ │ ├── EPS.hs │ │ ├── PDF.hs │ │ ├── Html.hs │ │ ├── Xml.hs │ │ └── Css.hs │ ├── Code │ │ ├── Go.hs │ │ ├── Lua.hs │ │ ├── Python.hs │ │ ├── C.hs │ │ ├── GLSL.hs │ │ ├── Js.hs │ │ └── Evm.hs │ ├── Pki │ │ ├── CRL.hs │ │ ├── X509.hs │ │ └── ASN1.hs │ ├── Network │ │ └── HTTP.hs │ ├── Image │ │ ├── Gif.hs │ │ ├── Tga.hs │ │ ├── Png.hs │ │ ├── Jpeg.hs │ │ ├── Tiff.hs │ │ └── SVG.hs │ ├── Archive │ │ ├── Tar.hs │ │ └── Zip.hs │ └── FormatInfo.hs │ ├── Derive │ ├── Show.hs │ ├── NFData.hs │ ├── Mutators.hs │ ├── Mutation.hs │ ├── Generator.hs │ ├── Fixable.hs │ └── Arbitrary.hs │ ├── Derive.hs │ └── Global.hs ├── app ├── Debug.hs ├── Run │ ├── List.hs │ ├── Shrink.hs │ ├── Exec.hs │ ├── Gen.hs │ ├── Serve.hs │ ├── Test.hs │ ├── GenTest.hs │ └── MutTest.hs ├── Utils.hs ├── Fuzzers.hs ├── Utils │ ├── Patch.hs │ ├── Unique.hs │ ├── Console.hs │ ├── Mutation.hs │ ├── Generation.hs │ ├── Decoding.hs │ └── Shrink.hs ├── Exception.hs ├── DeriveDispatcher.hs ├── Main.hs ├── Process.hs ├── Formats.hs └── Args.hs ├── .gitignore ├── install_fuzzers.sh ├── doc ├── adding-new-file-format.md └── haskell-style.md ├── stack.yaml ├── circle.yml ├── README.md └── QuickFuzz.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/Unicode.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Base.Unicode where 2 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Media.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Media 2 | ( module Test.QuickFuzz.Gen.Media.Wav 3 | ) where 4 | 5 | import Test.QuickFuzz.Gen.Media.Wav 6 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Bnfc 2 | ( module Test.QuickFuzz.Gen.Bnfc.Grammar, 3 | ) where 4 | 5 | import Test.QuickFuzz.Gen.Bnfc.Grammar 6 | 7 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Network.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Network 2 | ( module Test.QuickFuzz.Gen.Network.HTTP 3 | ) where 4 | 5 | import Test.QuickFuzz.Gen.Network.HTTP 6 | 7 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.bak 9 | # Files generated by cabal sandbox 10 | .cabal-sandbox/ 11 | cabal.sandbox.config 12 | 13 | # local HTF files 14 | .HTF 15 | -------------------------------------------------------------------------------- /app/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Debug (debug) where 4 | 5 | import System.IO 6 | 7 | debug :: String -> IO () 8 | debug message = 9 | #ifdef DEBUG 10 | hPutStrLn stderr message 11 | #else 12 | return () 13 | #endif 14 | 15 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Archive.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Archive 2 | ( module Test.QuickFuzz.Gen.Archive.Tar, 3 | module Test.QuickFuzz.Gen.Archive.Zip 4 | ) where 5 | 6 | import Test.QuickFuzz.Gen.Archive.Tar 7 | import Test.QuickFuzz.Gen.Archive.Zip 8 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc/Grammar.cf: -------------------------------------------------------------------------------- 1 | -- file Calc.bnfc 2 | EAdd. Exp ::= Exp "+" Exp1 ; 3 | ESub. Exp ::= Exp "-" Exp1 ; 4 | EMul. Exp1 ::= Exp1 "*" Exp2 ; 5 | EDiv. Exp1 ::= Exp1 "/" Exp2 ; 6 | EInt. Exp2 ::= Integer ; 7 | coercions Exp 2 ; 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | packages 3 | *.swp 4 | dist 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .virtualenv 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | ./QuickFuzz 21 | report.html 22 | make.sh 23 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Pki.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Pki 2 | ( module Test.QuickFuzz.Gen.Pki.ASN1, 3 | module Test.QuickFuzz.Gen.Pki.X509, 4 | module Test.QuickFuzz.Gen.Pki.CRL 5 | ) where 6 | 7 | import Test.QuickFuzz.Gen.Pki.ASN1 8 | import Test.QuickFuzz.Gen.Pki.X509 9 | import Test.QuickFuzz.Gen.Pki.CRL 10 | -------------------------------------------------------------------------------- /app/Run/List.hs: -------------------------------------------------------------------------------- 1 | module Run.List (runList) where 2 | 3 | import Data.List 4 | import Data.Ord 5 | 6 | import Args 7 | import Debug 8 | import Formats 9 | 10 | -- Run list subcommand 11 | runList :: IO () 12 | runList = do 13 | putStrLn "Supported formats:" 14 | mapM_ (putStrLn . fst) (sortBy (comparing fst) formats) 15 | 16 | 17 | -------------------------------------------------------------------------------- /app/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils 2 | ( module Utils.Generation 3 | , module Utils.Patch 4 | , module Utils.Console 5 | , module Utils.Shrink 6 | , module Utils.Unique 7 | ) where 8 | 9 | import Utils.Generation 10 | import Utils.Decoding 11 | import Utils.Mutation 12 | import Utils.Patch 13 | import Utils.Console 14 | import Utils.Shrink 15 | import Utils.Unique 16 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc/AbsGrammar.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Test.QuickFuzz.Gen.Bnfc.AbsGrammar where 4 | 5 | -- Haskell module generated by the BNF converter 6 | 7 | 8 | 9 | 10 | data Exp 11 | = EAdd Exp Exp 12 | | ESub Exp Exp 13 | | EMul Exp Exp 14 | | EDiv Exp Exp 15 | | EInt Integer 16 | deriving (Eq, Ord, Show, Read) 17 | 18 | -------------------------------------------------------------------------------- /app/Run/Shrink.hs: -------------------------------------------------------------------------------- 1 | module Run.Shrink (runShrink) where 2 | 3 | import Control.Monad 4 | 5 | import Test.QuickFuzz.Gen.FormatInfo 6 | 7 | import Args 8 | import Debug 9 | 10 | -- Run shrink subcommand 11 | runShrink :: QFCommand -> FormatInfo base actions -> IO () 12 | runShrink cmd fmt = do 13 | when (hasActions fmt) 14 | (putStrLn "Selected format supports actions base generation/shrinking!") 15 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.QuickFuzz.Derive.Show where 4 | 5 | import Data.Derive.Show 6 | import Data.DeriveTH 7 | 8 | import Language.Haskell.TH 9 | import Language.Haskell.TH.Syntax 10 | 11 | import Megadeth.Prim 12 | 13 | isArbInsName = isinsName ''Show 14 | 15 | devShow :: Name -> Q [Dec] 16 | devShow = megaderive (derive makeShow) isArbInsName 17 | -------------------------------------------------------------------------------- /app/Run/Exec.hs: -------------------------------------------------------------------------------- 1 | module Run.Exec (runExec) where 2 | 3 | import System.Directory 4 | import System.FilePath 5 | 6 | import Test.QuickFuzz.Gen.FormatInfo 7 | 8 | import Args 9 | import Debug 10 | 11 | -- Run exec subcommand 12 | runExec :: QFCommand -> FormatInfo base actions -> IO () 13 | runExec cmd fmt = putStrLn "Executing!" >> print cmd 14 | 15 | getFiles :: QFCommand -> IO [FilePath] 16 | getFiles cmd = undefined 17 | 18 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc/.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | script: 3 | - cabal install 4 | - cabal configure --enable-tests && cabal build && cabal test 5 | before_install: 6 | - sudo apt-get update -qq 7 | - sudo apt-get install jlex cup openjdk-6-jdk 8 | - sudo apt-get install g++ 9 | - sudo apt-get install texlive-latex-base 10 | - cd source 11 | env: CLASSPATH=".:/usr/share/java/JLex.jar:/usr/share/java/cup.jar" 12 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/NFData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.QuickFuzz.Derive.NFData where 4 | 5 | import Control.DeepSeq 6 | import Data.Derive.NFData 7 | import Data.DeriveTH 8 | 9 | import Language.Haskell.TH 10 | import Language.Haskell.TH.Syntax 11 | 12 | import Megadeth.Prim 13 | 14 | isArbInsName = isinsName ''NFData 15 | 16 | devNFData :: Name -> Q [Dec] 17 | devNFData = megaderive (derive makeNFData) isArbInsName 18 | -------------------------------------------------------------------------------- /app/Fuzzers.hs: -------------------------------------------------------------------------------- 1 | module Fuzzers where 2 | 3 | data Fuzzer = Zzuf | Radamsa deriving Show 4 | type FuzzerCommand = Int -> (String, [String]) 5 | 6 | defaultZzuf :: FuzzerCommand 7 | defaultZzuf seed = ("zzuf", ["-r", "0.000001:0.04", "-s", show seed]) 8 | 9 | defaultRadamsa :: FuzzerCommand 10 | defaultRadamsa seed = ("radamsa", ["-s", show seed]) 11 | 12 | -- | Fuzzers to raw commands mapping 13 | getFuzzerCommand :: Fuzzer -> FuzzerCommand 14 | getFuzzerCommand Zzuf = defaultZzuf 15 | getFuzzerCommand Radamsa = defaultRadamsa 16 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Image 2 | ( module Test.QuickFuzz.Gen.Image.SVG, 3 | module Test.QuickFuzz.Gen.Image.Gif, 4 | module Test.QuickFuzz.Gen.Image.Png, 5 | module Test.QuickFuzz.Gen.Image.Tiff, 6 | module Test.QuickFuzz.Gen.Image.Jpeg, 7 | module Test.QuickFuzz.Gen.Image.Tga 8 | ) where 9 | 10 | import Test.QuickFuzz.Gen.Image.SVG 11 | import Test.QuickFuzz.Gen.Image.Gif 12 | import Test.QuickFuzz.Gen.Image.Png 13 | import Test.QuickFuzz.Gen.Image.Tiff 14 | import Test.QuickFuzz.Gen.Image.Jpeg 15 | import Test.QuickFuzz.Gen.Image.Tga 16 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Base 2 | ( module Test.QuickFuzz.Gen.Base.ByteString 3 | , module Test.QuickFuzz.Gen.Base.Regex 4 | , module Test.QuickFuzz.Gen.Base.String 5 | , module Test.QuickFuzz.Gen.Base.Time 6 | , module Test.QuickFuzz.Gen.Base.Unicode 7 | , module Test.QuickFuzz.Gen.Base.Vector 8 | ) where 9 | 10 | import Test.QuickFuzz.Gen.Base.ByteString 11 | import Test.QuickFuzz.Gen.Base.Regex 12 | import Test.QuickFuzz.Gen.Base.String 13 | import Test.QuickFuzz.Gen.Base.Time 14 | import Test.QuickFuzz.Gen.Base.Unicode 15 | import Test.QuickFuzz.Gen.Base.Vector 16 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Document 2 | ( module Test.QuickFuzz.Gen.Document.Html, 3 | module Test.QuickFuzz.Gen.Document.Css, 4 | module Test.QuickFuzz.Gen.Document.PDF, 5 | module Test.QuickFuzz.Gen.Document.PS, 6 | module Test.QuickFuzz.Gen.Document.EPS, 7 | module Test.QuickFuzz.Gen.Document.Xml 8 | ) where 9 | 10 | import Test.QuickFuzz.Gen.Document.Html 11 | import Test.QuickFuzz.Gen.Document.Css 12 | import Test.QuickFuzz.Gen.Document.PDF 13 | import Test.QuickFuzz.Gen.Document.PS 14 | import Test.QuickFuzz.Gen.Document.EPS 15 | import Test.QuickFuzz.Gen.Document.Xml 16 | 17 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Gen.Code 2 | ( module Test.QuickFuzz.Gen.Code.C, 3 | module Test.QuickFuzz.Gen.Code.Js, 4 | module Test.QuickFuzz.Gen.Code.Python, 5 | module Test.QuickFuzz.Gen.Code.Go, 6 | module Test.QuickFuzz.Gen.Code.Lua, 7 | module Test.QuickFuzz.Gen.Code.GLSL, 8 | module Test.QuickFuzz.Gen.Code.Evm 9 | ) where 10 | 11 | import Test.QuickFuzz.Gen.Code.C 12 | import Test.QuickFuzz.Gen.Code.Js 13 | import Test.QuickFuzz.Gen.Code.Python 14 | import Test.QuickFuzz.Gen.Code.Go 15 | import Test.QuickFuzz.Gen.Code.Lua 16 | import Test.QuickFuzz.Gen.Code.GLSL 17 | import Test.QuickFuzz.Gen.Code.Evm 18 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Derive 2 | ( module Test.QuickFuzz.Derive.Actions 3 | , module Test.QuickFuzz.Derive.Arbitrary 4 | , module Test.QuickFuzz.Derive.Fixable 5 | , module Test.QuickFuzz.Derive.Mutation 6 | , module Test.QuickFuzz.Derive.Show 7 | , module Test.QuickFuzz.Derive.Generator 8 | ) where 9 | 10 | import Test.QuickFuzz.Derive.Actions 11 | import Test.QuickFuzz.Derive.Arbitrary 12 | import Test.QuickFuzz.Derive.Fixable 13 | import Test.QuickFuzz.Derive.Generator 14 | import Test.QuickFuzz.Derive.Mutation 15 | import Test.QuickFuzz.Derive.Show 16 | import Test.QuickFuzz.Derive.NFData 17 | -------------------------------------------------------------------------------- /install_fuzzers.sh: -------------------------------------------------------------------------------- 1 | # sudo apt-get install bnfc 2 | cd src/Test/QuickFuzz/Gen/Bnfc/ 3 | bnfc --haskell Grammar.cf -p Test.QuickFuzz.Gen.Bnfc 4 | mv Test/QuickFuzz/Gen/Bnfc/* . 5 | rm -rf Test 6 | cd ../../../../../ 7 | 8 | _PKG_DIR="packages" 9 | 10 | mkdir -p $_PKG_DIR 11 | cd $_PKG_DIR 12 | 13 | git clone https://github.com/CIFASIS/radamsa 14 | cd radamsa 15 | git pull 16 | make install DESTDIR=$HOME/.local PREFIX="" 17 | cd .. 18 | 19 | git clone https://github.com/CIFASIS/zzuf 20 | cd zzuf 21 | ./bootstrap 22 | ./configure --prefix=$HOME/.local 23 | make install 24 | 25 | cd .. 26 | 27 | git clone https://github.com/CIFASIS/honggfuzz 28 | cd honggfuzz 29 | make 30 | cp ./honggfuzz $HOME/.local/bin 31 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/String.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, IncoherentInstances #-} 2 | module Test.QuickFuzz.Gen.Base.String where 3 | 4 | import Test.QuickCheck 5 | 6 | import qualified Data.Text as TS 7 | import qualified Data.Text.Lazy as TL 8 | import Test.QuickFuzz.Gen.Base.Value 9 | 10 | -- String 11 | 12 | instance Arbitrary String where 13 | arbitrary = genStrValue "String" 14 | 15 | -- Text 16 | instance Arbitrary TS.Text where 17 | arbitrary = TS.pack <$> genStrValue "Text" 18 | shrink xs = TS.pack <$> shrink (TS.unpack xs) 19 | 20 | instance Arbitrary TL.Text where 21 | arbitrary = TL.pack <$> genStrValue "Text" 22 | shrink xs = TL.pack <$> shrink (TL.unpack xs) 23 | 24 | instance CoArbitrary TS.Text where 25 | coarbitrary = coarbitrary . TS.unpack 26 | 27 | instance CoArbitrary TL.Text where 28 | coarbitrary = coarbitrary . TL.unpack 29 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Media/Wav.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Media.Wav where 7 | 8 | import Data.Default 9 | 10 | import qualified Data.Binary as B 11 | 12 | import Control.DeepSeq 13 | 14 | import Sound.Wav 15 | 16 | import Test.QuickCheck 17 | 18 | import Test.QuickFuzz.Derive.Arbitrary 19 | import Test.QuickFuzz.Derive.Show 20 | import Test.QuickFuzz.Derive.NFData 21 | import Test.QuickFuzz.Derive.Mutation 22 | import Test.QuickFuzz.Gen.FormatInfo 23 | import Test.QuickFuzz.Gen.Base.ByteString 24 | 25 | devArbitrary ''WaveFile 26 | devMutation ''WaveFile 27 | devNFData ''WaveFile 28 | 29 | wavInfo :: FormatInfo WaveFile NoActions 30 | wavInfo = def 31 | { encode = B.encode 32 | , decode = B.decode 33 | , random = arbitrary 34 | , mutate = mutt 35 | , ext = "wav" 36 | } 37 | -------------------------------------------------------------------------------- /app/Utils/Patch.hs: -------------------------------------------------------------------------------- 1 | module Utils.Patch where 2 | 3 | import Prelude hiding (concat) 4 | 5 | import Data.ByteString.Lazy (ByteString, pack, unpack, concat, toStrict) 6 | 7 | import Data.String 8 | import Data.Algorithm.Diff 9 | import Data.ByteString.Search 10 | 11 | 12 | type Patch = (ByteString, ByteString, ByteString, ByteString) 13 | 14 | diff :: ByteString -> ByteString -> [Patch] 15 | diff old new = groupDiffs (getGroupedDiff (unpack old) (unpack new)) 16 | 17 | groupDiffs (Both pre _ : First old : Second new : Both pos _ : xs) = 18 | (pack pre, pack pos, pack (take (length new) old), pack new) : groupDiffs xs 19 | groupDiffs (x:xs) = groupDiffs xs 20 | groupDiffs _ = [] 21 | 22 | 23 | patch :: [Patch] -> ByteString -> ByteString 24 | patch [] orig = orig 25 | patch (p:ps) orig = patch ps (applyPatch p orig) 26 | 27 | applyPatch :: Patch -> ByteString -> ByteString 28 | applyPatch (pre, pos, old, new) orig = 29 | replace (toStrict (concat [pre,old,pos])) 30 | (concat [pre,new,pos]) 31 | (toStrict orig) 32 | -------------------------------------------------------------------------------- /app/Run/Gen.hs: -------------------------------------------------------------------------------- 1 | module Run.Gen (runGen) where 2 | 3 | import Prelude hiding (writeFile) 4 | 5 | import Data.ByteString.Lazy 6 | 7 | import Control.Monad 8 | 9 | import System.FilePath 10 | import System.Directory 11 | 12 | import Test.QuickCheck (generate, resize) 13 | import Test.QuickFuzz.Gen.FormatInfo 14 | 15 | import Args 16 | import Debug 17 | import Exception 18 | import Utils 19 | 20 | -- |Run gen subcommand 21 | runGen :: (Show actions, Show base) => 22 | QFCommand -> FormatInfo base actions -> IO () 23 | runGen cmd fmt = do 24 | debug (show cmd) 25 | mkName <- nameMaker cmd fmt 26 | 27 | createDirectoryIfMissing True (outDir cmd) 28 | let steps | usesSeed cmd = [0] 29 | | otherwise = [0..genQty cmd] 30 | 31 | forM_ steps $ \n -> handleSigInt (return ()) $ do 32 | 33 | let size = linearSize cmd n 34 | 35 | (mbacts, encoded, seed) <- strictGenerate cmd fmt size 36 | writeFile (mkName n seed size) encoded 37 | 38 | printGenStep n 39 | 40 | printFinished 41 | -------------------------------------------------------------------------------- /app/Exception.hs: -------------------------------------------------------------------------------- 1 | module Exception where 2 | 3 | import Prelude hiding (writeFile) 4 | 5 | import Control.Exception 6 | import Data.ByteString.Lazy 7 | import Control.DeepSeq 8 | import Control.Seq 9 | 10 | import Debug 11 | 12 | --import qualified Data.ByteString.Lazy.Char8 as LC8 13 | --import Control.Monad 14 | 15 | --enc_handler :: SomeException -> IO LC8.ByteString 16 | --enc_handler x = return $ LC8.pack "" 17 | 18 | --dec_handler :: SomeException -> IO (Maybe a) 19 | --dec_handler x = return Nothing 20 | --mcatch x = Control.Exception.catch (return $ Just x) dec_handler 21 | 22 | handlePrint :: SomeException -> IO () 23 | handlePrint = debug . show 24 | 25 | handleDecode :: SomeException -> IO (Maybe a) 26 | handleDecode x = handlePrint x >> return Nothing 27 | 28 | toNF :: (NFData a) => a -> IO a 29 | toNF = evaluate . withStrategy rdeepseq 30 | 31 | forceEvaluation :: (NFData a) => a -> IO (Maybe a) 32 | forceEvaluation x = handle handleDecode (toNF (Just x)) 33 | 34 | --write :: FilePath -> ByteString -> IO () 35 | --write filename x = handle handlePrint (writeFile filename x) 36 | -------------------------------------------------------------------------------- /app/Utils/Unique.hs: -------------------------------------------------------------------------------- 1 | module Utils.Unique where 2 | 3 | import System.Environment 4 | import System.FilePath 5 | import System.Directory 6 | 7 | import Data.Time 8 | 9 | import Test.QuickFuzz.Gen.FormatInfo 10 | 11 | import Args 12 | 13 | -- |Return a unique filename 14 | testName :: FormatInfo base actions -> IO String 15 | testName fmt = do 16 | qf <- getProgName 17 | ts <- getTimestamp 18 | return $ qf <.> ts <.> ext fmt 19 | 20 | -- |Return a unique timestamp 21 | getTimestamp :: IO String 22 | getTimestamp = 23 | show . (`div` 1000000) . fromEnum . utctDayTime <$> getCurrentTime 24 | 25 | -- |Return a function that generates uniquely parametrized filenames 26 | -- Filenames looks like: 27 | -- outdir/progName.timestamp.testNumber.genSeed.genSize.ext 28 | nameMaker :: Show a => QFCommand -> FormatInfo base actions 29 | -> IO (a -> a -> a -> String) 30 | nameMaker cmd fmt = do 31 | qf <- getProgName 32 | ts <- getTimestamp 33 | return (\step seed size -> outDir cmd qf 34 | <.> ts <.> show step <.> show seed <.> show size <.> ext fmt) 35 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/ByteString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, IncoherentInstances#-} 2 | module Test.QuickFuzz.Gen.Base.ByteString where 3 | 4 | import Test.QuickCheck 5 | 6 | import qualified Data.ByteString.Lazy.Char8 as L8 7 | import qualified Data.ByteString.Lazy as L 8 | import qualified Data.ByteString as B 9 | 10 | import Data.Word(Word8, Word16, Word32) 11 | import Data.Int( Int16, Int8 ) 12 | import Data.List( init ) 13 | 14 | import Test.QuickFuzz.Gen.Base.Value 15 | 16 | instance Arbitrary B.ByteString where 17 | arbitrary = do 18 | --l <- listOf (arbitrary :: Gen Word8) 19 | x <- genStrValue "ByteString" 20 | return $ L8.toStrict $ L8.pack x 21 | 22 | instance Arbitrary L.ByteString where 23 | arbitrary = do 24 | --l <- listOf (arbitrary :: Gen Word8) 25 | x <- genStrValue "ByteString" 26 | return $ L8.pack x 27 | 28 | shrink xs = ys -- ++ concat (map shrink ys) 29 | where ys = tail (L.tails xs) ++ init (L.inits xs) 30 | 31 | instance CoArbitrary L.ByteString where 32 | coarbitrary x = coarbitrary $ L.unpack x 33 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances#-} 2 | 3 | module Test.QuickFuzz.Gen.Base.Vector where 4 | 5 | import Test.QuickCheck 6 | import qualified Data.Vector as V 7 | import qualified Data.Vector.Unboxed as VU 8 | import qualified Data.Vector.Storable as VS 9 | import Data.Word(Word8) 10 | 11 | instance Arbitrary a => Arbitrary (V.Vector a) where 12 | arbitrary = do 13 | l <- listOf arbitrary 14 | return $ V.fromList l 15 | 16 | instance (VU.Unbox a, Arbitrary a) => Arbitrary (VU.Vector a) where 17 | arbitrary = do 18 | l <- listOf arbitrary 19 | return $ VU.fromList l 20 | 21 | instance (VS.Storable a, Arbitrary a) => Arbitrary (VS.Vector a) where 22 | arbitrary = do 23 | l <- listOf arbitrary 24 | return $ VS.fromList l 25 | 26 | instance Arbitrary (V.Vector (VU.Vector Word8)) where 27 | arbitrary = do 28 | l <- listOf (arbitrary :: Gen Word8) 29 | x <- (arbitrary :: Gen Int) 30 | --return $ V.replicate (x `mod` 32) (VU.fromList l) 31 | return $ V.replicate x (VU.fromList l) 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document/PS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Document.PS where 7 | 8 | import Data.Default 9 | import Test.QuickCheck 10 | 11 | import qualified Data.ByteString.Lazy.Char8 as L8 12 | 13 | import Graphics.EasyRender 14 | import Graphics.EasyRender.Internal 15 | 16 | import Test.QuickFuzz.Derive.Actions 17 | import Test.QuickFuzz.Derive.Arbitrary 18 | import Test.QuickFuzz.Derive.Show 19 | import Test.QuickFuzz.Gen.FormatInfo 20 | import Test.QuickFuzz.Gen.Base.ByteString 21 | import Test.QuickFuzz.Gen.Base.String 22 | 23 | import Test.QuickFuzz.Gen.Document.PDF 24 | 25 | psInfo :: FormatInfo (Draw()) [DrawAction] 26 | psInfo = def 27 | { encode = L8.pack . render_string Format_PS . newpage 1024 1024 28 | , random = arbitrary 29 | , actions = Just $ def 30 | { randomActions = arbitrary 31 | , shrinkActions = shrinkActionList shrinkDrawAction 32 | , performActions = performDrawAction } 33 | , ext = "ps" 34 | } 35 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document/EPS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Document.EPS where 7 | 8 | import Data.Default 9 | import Test.QuickCheck 10 | 11 | import qualified Data.ByteString.Lazy.Char8 as L8 12 | 13 | import Graphics.EasyRender 14 | import Graphics.EasyRender.Internal 15 | 16 | import Test.QuickFuzz.Derive.Actions 17 | import Test.QuickFuzz.Derive.Arbitrary 18 | import Test.QuickFuzz.Derive.Show 19 | import Test.QuickFuzz.Gen.FormatInfo 20 | import Test.QuickFuzz.Gen.Base.ByteString 21 | import Test.QuickFuzz.Gen.Base.String 22 | 23 | import Test.QuickFuzz.Gen.Document.PDF 24 | 25 | epsInfo :: FormatInfo (Draw()) [DrawAction] 26 | epsInfo = def 27 | { encode = L8.pack . render_string (Format_EPS 0) . newpage 1024 1024 28 | , random = arbitrary 29 | , actions = Just $ def 30 | { randomActions = arbitrary 31 | , shrinkActions = shrinkActionList shrinkDrawAction 32 | , performActions = performDrawAction } 33 | , ext = "eps" 34 | } 35 | -------------------------------------------------------------------------------- /doc/adding-new-file-format.md: -------------------------------------------------------------------------------- 1 | # How to add a new file format to generate and mutate in QuickFuzz 2 | 3 | First, clone the QuickFuzz repository and make sure it compiles using 4 | the "all" flag. Then, suppose you want to add a new image format called FMT 5 | in the "image" section. 6 | 7 | 1. Create the file FMT.hs inside src/Test/QuickFuzz/Gen/Image/ 8 | The module name should be Test.QuickFuzz.Gen.Image.FMT and it should properly 9 | define arbitrary and show instances of a type representing IMG files. 10 | 2. Declare a FormatInfo value named imgInfo: 11 | 12 | ``` 13 | imgInfo :: FormatInfo IMGFile NoActions 14 | imgInfo = def 15 | { encode = imgencode 16 | , random = arbitrary 17 | , value = show 18 | , ext = "img" 19 | } 20 | ``` 21 | 22 | 3. Declare and export Test.QuickFuzz.Gen.Image.FMT in src/Test/QuickFuzz/Gen/Image.hs 23 | 4. Add ("img", 'imgInfo) into the IMAGE part in the formats list in app/Formats.hs 24 | 5. Add the necesary modules to compile the FMT module into the IMAGE section in QuickFuzz.cabal 25 | 6. Add Test.QuickFuzz.Gen.Image.FMT in the exposed modules into the IMAGE section in QuickFuzz.cabal 26 | 27 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/Go.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Code.Go where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck 11 | import Control.DeepSeq 12 | import Control.Monad 13 | import Control.Monad.Trans 14 | import Control.Monad.Trans.State 15 | import Data.List 16 | 17 | import Language.Go.Syntax.AST 18 | import Language.Go.Pretty 19 | import Text.PrettyPrint (render) 20 | 21 | import Test.QuickFuzz.Derive.Arbitrary 22 | import Test.QuickFuzz.Derive.Fixable 23 | import Test.QuickFuzz.Derive.Show 24 | import Test.QuickFuzz.Derive.NFData 25 | import Test.QuickFuzz.Gen.FormatInfo 26 | import Test.QuickFuzz.Gen.Base.ByteString 27 | import Test.QuickFuzz.Gen.Base.String 28 | 29 | import qualified Data.ByteString.Lazy.Char8 as L8 30 | 31 | devArbitrary ''GoSource 32 | devNFData ''GoSource 33 | 34 | goInfo :: FormatInfo GoSource NoActions 35 | goInfo = def 36 | { encode = L8.pack . render . pretty 37 | , random = arbitrary 38 | , value = show 39 | , ext = "go" 40 | } 41 | -------------------------------------------------------------------------------- /app/DeriveDispatcher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module DeriveDispatcher (devDispatcher) where 4 | 5 | import Language.Haskell.TH 6 | 7 | import Args 8 | import Formats 9 | 10 | funName = mkName . ("dispatch"++) . nameBase 11 | 12 | devDispatcher :: Name -> Name -> DecsQ 13 | devDispatcher action runner = pure <$> funD (funName action) funClause 14 | where funClause = [clause [varP (mkName "cmd")] funBody []] 15 | funBody = normalB $ caseE ((varE (mkName "format")) 16 | `appE` (varE (mkName "cmd"))) funCases 17 | funCases = fmtsCases ++ [unsupCase] 18 | unsupCase = match (varP (mkName "fmt")) 19 | (normalB ((varE (mkName "unsupported")) 20 | `appE` (varE (mkName "fmt")))) [] 21 | fmtsCases = map fmtCase formats 22 | fmtCase (fmt, info) = match (litP (stringL fmt)) 23 | (normalB ((varE runner) 24 | `appE` (varE (mkName "cmd")) 25 | `appE` (varE info))) [] 26 | 27 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Pki/CRL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Pki.CRL where 7 | 8 | import Data.Default 9 | 10 | import Data.X509 11 | import Data.ASN1.Types 12 | import Data.ASN1.Encoding 13 | import Data.ASN1.BinaryEncoding 14 | import Data.ASN1.BitArray 15 | import Time.Types 16 | 17 | import Test.QuickCheck 18 | import Control.Monad 19 | import Control.DeepSeq 20 | import Control.Monad.Trans 21 | import Control.Monad.Trans.State 22 | import Data.List 23 | import Data.Monoid 24 | 25 | import Test.QuickFuzz.Derive.Arbitrary 26 | import Test.QuickFuzz.Derive.NFData 27 | import Test.QuickFuzz.Derive.Show 28 | import Test.QuickFuzz.Gen.FormatInfo 29 | import Test.QuickFuzz.Gen.Base.ByteString 30 | import Test.QuickFuzz.Gen.Base.String 31 | 32 | import qualified Data.ByteString.Lazy as L 33 | 34 | devArbitrary ''CRL 35 | devNFData ''CRL 36 | 37 | crlInfo :: FormatInfo CRL NoActions 38 | crlInfo = def 39 | { encode = L.fromStrict . (\x -> encodeASN1' DER (toASN1 x [])) 40 | , random = arbitrary 41 | , value = show 42 | , ext = "crl" 43 | } 44 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Pki/X509.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Pki.X509 where 7 | 8 | import Data.Default 9 | 10 | import Data.X509 11 | import Data.ASN1.Types 12 | import Data.ASN1.Encoding 13 | import Data.ASN1.BitArray 14 | import Data.ASN1.BinaryEncoding 15 | import Crypto.PubKey.ECC.Types 16 | 17 | import Time.Types 18 | 19 | import Test.QuickCheck 20 | import Control.Monad 21 | import Control.DeepSeq 22 | import Control.Monad.Trans 23 | import Control.Monad.Trans.State 24 | import Data.List 25 | import Data.Monoid 26 | 27 | import Test.QuickFuzz.Derive.Arbitrary 28 | import Test.QuickFuzz.Derive.NFData 29 | import Test.QuickFuzz.Derive.Show 30 | import Test.QuickFuzz.Gen.FormatInfo 31 | import Test.QuickFuzz.Gen.Base.ByteString 32 | import Test.QuickFuzz.Gen.Base.String 33 | 34 | import qualified Data.ByteString.Lazy as L 35 | 36 | devArbitrary ''Certificate 37 | devNFData ''Certificate 38 | 39 | x509Info :: FormatInfo Certificate NoActions 40 | x509Info = def 41 | { encode = L.fromStrict . (\x -> encodeASN1' DER (toASN1 x [])) 42 | , random = arbitrary 43 | , value = show 44 | , ext = "x509" 45 | } 46 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc/Grammar.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE IncoherentInstances #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | 7 | 8 | module Test.QuickFuzz.Gen.Bnfc.Grammar where 9 | 10 | import Test.QuickFuzz.Gen.Bnfc.PrintGrammar as Print 11 | import Test.QuickFuzz.Gen.Bnfc.AbsGrammar as Abstract 12 | 13 | import Data.Char 14 | import Data.Default 15 | import Data.Text.Encoding (encodeUtf8) 16 | import Control.DeepSeq 17 | import Test.QuickCheck 18 | import Test.QuickFuzz.Derive.Arbitrary 19 | import Test.QuickFuzz.Derive.Show 20 | import Test.QuickFuzz.Derive.NFData 21 | --import Test.QuickFuzz.Derive.Mutation 22 | import Test.QuickFuzz.Gen.FormatInfo 23 | import Test.QuickFuzz.Gen.Base.ByteString 24 | import qualified Data.ByteString.Lazy.Char8 as L8 25 | 26 | devShow ''Abstract.Exp 27 | devArbitrary ''Abstract.Exp 28 | devNFData ''Abstract.Exp 29 | --devMutation ''Abstract.Exp 30 | 31 | 32 | bnfcInfo :: FormatInfo Exp NoActions 33 | bnfcInfo = def 34 | { encode = L8.pack . Print.printTree 35 | , random = arbitrary 36 | , value = show 37 | , ext = "ext" 38 | } 39 | 40 | -- ./install_fuzzers.sh ; rm -rf outdir ; stack install --flag QuickFuzz:all ; QuickFuzz gen bnfc 41 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Network/HTTP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Network.HTTP where 7 | 8 | import Data.Default 9 | import Data.Text.Encoding (encodeUtf8) 10 | 11 | import Network.HTTP.Headers 12 | import Network.HTTP.Base 13 | import Control.DeepSeq 14 | import Test.QuickCheck 15 | 16 | import Test.QuickFuzz.Derive.Arbitrary 17 | import Test.QuickFuzz.Derive.Show 18 | import Test.QuickFuzz.Derive.NFData 19 | import Test.QuickFuzz.Gen.FormatInfo 20 | import Test.QuickFuzz.Gen.Base.ByteString 21 | import qualified Data.ByteString.Lazy.Char8 as L8 22 | 23 | 24 | devArbitrary ''Request 25 | devShow ''Request 26 | devNFData ''Request 27 | 28 | httpRequestInfo :: FormatInfo (Request String) NoActions 29 | httpRequestInfo = def 30 | { encode = L8.pack . show 31 | , random = arbitrary 32 | , value = show 33 | , ext = "http" 34 | } 35 | 36 | devArbitrary ''Response 37 | devShow ''Response 38 | devNFData ''Response 39 | 40 | httpResponseInfo :: FormatInfo (Response String) NoActions 41 | httpResponseInfo = def 42 | { encode = L8.pack . show 43 | , random = arbitrary 44 | , value = show 45 | , ext = "http" 46 | } 47 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image/Gif.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Image.Gif where 7 | 8 | import Data.Default 9 | 10 | import qualified Data.Binary 11 | import Codec.Picture.Gif 12 | import Codec.Picture.Types 13 | import Codec.Picture.ColorQuant 14 | 15 | import Test.QuickCheck 16 | import Control.Monad 17 | import Control.DeepSeq 18 | 19 | import Control.Monad.Trans 20 | import Control.Monad.Trans.State 21 | import Data.List 22 | import Data.Monoid 23 | 24 | import Test.QuickFuzz.Derive.Arbitrary 25 | import Test.QuickFuzz.Derive.NFData 26 | 27 | import Test.QuickFuzz.Derive.Show 28 | import Test.QuickFuzz.Gen.FormatInfo 29 | import Test.QuickFuzz.Gen.Base.ByteString 30 | import Test.QuickFuzz.Gen.Base.String 31 | import Test.QuickFuzz.Gen.Base.Image 32 | 33 | import qualified Data.ByteString.Lazy as L 34 | 35 | devShow ''GifFile 36 | devArbitrary ''GifFile 37 | devNFData ''GifFile 38 | 39 | gifencode :: GifFile -> L.ByteString 40 | gifencode = Data.Binary.encode 41 | 42 | gifInfo :: FormatInfo GifFile NoActions 43 | gifInfo = def 44 | { encode = gifencode 45 | , random = arbitrary 46 | , value = show 47 | , ext = "gif" 48 | } 49 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/Lua.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Code.Lua (luaInfo) where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck 11 | import Control.Monad 12 | import Control.Monad.Trans 13 | import Control.Monad.Trans.State 14 | import Data.List 15 | 16 | import Language.Lua.Syntax 17 | import Language.Lua.PrettyPrinter 18 | import Language.Lua.Parser 19 | 20 | import Test.QuickFuzz.Derive.Arbitrary 21 | import Test.QuickFuzz.Derive.Fixable 22 | import Test.QuickFuzz.Derive.Show 23 | import Test.QuickFuzz.Derive.Mutation 24 | import Test.QuickFuzz.Gen.FormatInfo 25 | import Test.QuickFuzz.Gen.Base.ByteString 26 | import Test.QuickFuzz.Gen.Base.String 27 | 28 | import qualified Data.ByteString.Lazy.Char8 as L8 29 | import Data.ByteString.Lazy as L 30 | import Data.Text.Encoding (decodeUtf8) 31 | 32 | devArbitrary ''Block 33 | devMutation ''Block 34 | 35 | decode' x = either undefined id $ parseText chunk (decodeUtf8 $ L.toStrict x) 36 | 37 | luaInfo :: FormatInfo Block NoActions 38 | luaInfo = def 39 | { encode = L8.pack . show . pprint 40 | , decode = decode' 41 | , mutate = mutt 42 | , random = arbitrary 43 | , value = show 44 | , ext = "lua" 45 | } 46 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Pki/ASN1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Pki.ASN1 where 7 | 8 | import Data.Default 9 | 10 | import Data.ASN1.Types 11 | import Data.ASN1.BitArray 12 | import Data.ASN1.Encoding 13 | import Data.ASN1.BinaryEncoding 14 | import Time.Types 15 | 16 | import Test.QuickCheck 17 | import Control.Monad 18 | import Control.DeepSeq 19 | import Control.Monad.Trans 20 | import Control.Monad.Trans.State 21 | import Data.List 22 | import Data.Monoid 23 | 24 | import Test.QuickFuzz.Derive.Arbitrary 25 | import Test.QuickFuzz.Derive.Mutation 26 | import Test.QuickFuzz.Derive.Show 27 | import Test.QuickFuzz.Derive.NFData 28 | import Test.QuickFuzz.Gen.FormatInfo 29 | import Test.QuickFuzz.Gen.Base.ByteString 30 | import Test.QuickFuzz.Gen.Base.String 31 | 32 | import qualified Data.ByteString.Lazy as L 33 | 34 | devArbitrary ''ASN1 35 | devMutation ''ASN1 36 | devNFData ''ASN1 37 | 38 | decode' bs = either undefined id $ decodeASN1 DER bs 39 | 40 | asn1Info :: FormatInfo [ASN1] NoActions 41 | asn1Info = def 42 | { encode = L.fromStrict . (encodeASN1' DER) 43 | , decode = decode' 44 | , mutate = mutt 45 | , random = arbitrary 46 | , value = show 47 | , ext = "asn1" 48 | } 49 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, IncoherentInstances #-} 2 | module Test.QuickFuzz.Gen.Base.Value where 3 | 4 | import Test.QuickCheck 5 | import Data.Char (chr) 6 | 7 | import Test.QuickFuzz.Global 8 | 9 | genStrValue :: String -> Gen String 10 | genStrValue name = sized $ \n -> do 11 | n <- arbitrary :: Gen Int 12 | f <- arbitrary :: Gen Float 13 | x <- arbitrary :: Gen Char 14 | --s <- resize (max n 10) genName :: Gen String 15 | ss <- mgenName :: Gen String 16 | --ls <- lgenName :: Gen String 17 | frequency $ zip freqs $ map return [ show n, show f, [x], ss] 18 | where freqs = getFreqs name 19 | 20 | genName :: Gen String 21 | genName = listOf1 validChars :: Gen String 22 | where validChars = chr <$> choose (97, 122) 23 | 24 | lgenName :: Gen String 25 | lgenName = do 26 | n <- arbitrary :: Gen Int 27 | x <- arbitrary :: Gen Char 28 | return $ replicate (1000 * (n `mod` 50)) x 29 | 30 | sgenName :: Int -> Gen String 31 | sgenName 1 = do 32 | c <- chr <$> choose (97,122) 33 | return $ [c] 34 | 35 | sgenName n = do 36 | c <- chr <$> choose (97,122) 37 | n <- sgenName (max (n `div` 2) 1) 38 | return $ c : n 39 | 40 | mgenName = oneof $ map return ["a", "b", "c"] 41 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Archive/Tar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Archive.Tar where 7 | 8 | import Data.Default 9 | 10 | import Control.Exception 11 | import Data.ByteString.Lazy 12 | import Test.QuickCheck 13 | 14 | import Codec.Archive.Tar 15 | import Codec.Archive.Tar.Entry 16 | -- Dirty hack to put Codec.Archive.Tar.Types in scope, since it is 17 | -- hidden, but reexported in Codec.Archive.Tar.Entry 18 | import Codec.Archive.Tar.Entry as Codec.Archive.Tar.Types 19 | 20 | import Test.QuickFuzz.Derive.Arbitrary 21 | import Test.QuickFuzz.Derive.Actions 22 | import Test.QuickFuzz.Derive.Show 23 | import Test.QuickFuzz.Gen.FormatInfo 24 | import Test.QuickFuzz.Gen.Base.ByteString 25 | 26 | devActions ["Codec.Archive.Tar.Entry"] ''Entry False [''Entry] [] 27 | devArbitrary ''EntryAction 28 | devArbitraryWithActions False ''Entry 29 | devShow ''Entry 30 | devShow ''EntryAction 31 | 32 | tarInfo :: FormatInfo [Entry] EntryAction 33 | tarInfo = def 34 | { encode = write 35 | , random = arbitrary 36 | , value = show 37 | , actions = Just $ def 38 | { randomActions = arbitrary 39 | , shrinkActions = shrinkEntryAction 40 | , performActions = pure . performEntryAction } 41 | , ext = "tar" 42 | } 43 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image/Tga.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Image.Tga where 7 | 8 | import Data.Default 9 | 10 | import qualified Data.Binary 11 | 12 | import Test.QuickCheck 13 | import Control.DeepSeq 14 | import Control.Monad 15 | import Control.Monad.Trans 16 | import Control.Monad.Trans.State 17 | import Data.List 18 | 19 | import Codec.Picture.Types 20 | import Codec.Picture.Tga.Types 21 | import Codec.Picture.Metadata.Exif 22 | import Codec.Picture.Metadata 23 | 24 | import Test.QuickFuzz.Derive.Arbitrary 25 | import Test.QuickFuzz.Derive.Actions 26 | import Test.QuickFuzz.Derive.Show 27 | import Test.QuickFuzz.Derive.NFData 28 | 29 | import Test.QuickFuzz.Gen.FormatInfo 30 | import Test.QuickFuzz.Gen.Base.ByteString 31 | import Test.QuickFuzz.Gen.Base.String 32 | import Test.QuickFuzz.Gen.Base.Image 33 | import Test.QuickFuzz.Gen.Base.Vector 34 | 35 | import qualified Data.ByteString.Lazy as L 36 | 37 | devArbitrary ''TgaFile_t 38 | devShow ''TgaFile_t 39 | devNFData ''TgaFile_t 40 | 41 | tgaencode :: TgaFile_t -> L.ByteString 42 | tgaencode = Data.Binary.encode 43 | 44 | tgaInfo :: FormatInfo TgaFile_t NoActions 45 | tgaInfo = def 46 | { encode = tgaencode 47 | , random = arbitrary 48 | , value = show 49 | , ext = "tga" 50 | } 51 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/Python.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Code.Python (pyInfo) where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck 11 | 12 | import Data.ByteString.Lazy.Char8 as L8 13 | import Data.ByteString.Lazy as L 14 | import Data.Text (unpack) 15 | import Data.Text.Encoding (decodeUtf8) 16 | 17 | import Control.DeepSeq 18 | import Language.Python.Common 19 | import Language.Python.Common.Pretty 20 | import Language.Python.Version2.Parser 21 | 22 | import Test.QuickFuzz.Derive.Arbitrary 23 | import Test.QuickFuzz.Derive.Fixable 24 | import Test.QuickFuzz.Derive.Show 25 | import Test.QuickFuzz.Derive.NFData 26 | import Test.QuickFuzz.Derive.Mutation 27 | 28 | import Test.QuickFuzz.Gen.FormatInfo 29 | import Test.QuickFuzz.Gen.Base.ByteString 30 | import Test.QuickFuzz.Gen.Base.String 31 | 32 | 33 | type Py = Module SrcSpan 34 | 35 | devArbitrary ''Py 36 | devNFData ''Module 37 | devNFData ''SrcSpan 38 | devMutation ''Py 39 | 40 | decode' x = either undefined fst $ parseModule (Data.Text.unpack $ decodeUtf8 $ L.toStrict x) "" 41 | 42 | pyInfo :: FormatInfo Py NoActions 43 | pyInfo = def 44 | { encode = L8.pack . prettyText 45 | , decode = decode' 46 | , mutate = mutt 47 | , random = arbitrary 48 | , value = show 49 | , ext = "py" 50 | } 51 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Archive/Zip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Archive.Zip ( 7 | zipInfo 8 | ) where 9 | 10 | import Data.Default 11 | 12 | import Control.Exception 13 | import Control.DeepSeq 14 | import Data.ByteString.Lazy 15 | import Test.QuickCheck 16 | import Data.Word 17 | 18 | import Codec.Archive.Zip 19 | 20 | import Test.QuickFuzz.Derive.Arbitrary 21 | import Test.QuickFuzz.Derive.Actions 22 | import Test.QuickFuzz.Derive.Show 23 | import Test.QuickFuzz.Derive.NFData 24 | import Test.QuickFuzz.Gen.FormatInfo 25 | import Test.QuickFuzz.Gen.Base.ByteString 26 | import Test.QuickFuzz.Gen.Base.String 27 | 28 | $(devActions ["Codec.Archive.Zip"] ''Entry False [] []) 29 | $(devArbitrary ''EntryAction) 30 | $(devArbitraryWithActions False ''Entry) 31 | 32 | $(devShow ''EntryAction) 33 | 34 | $(devActions ["Codec.Archive.Zip"] ''Archive False [] []) 35 | $(devArbitrary ''ArchiveAction) 36 | $(devArbitraryWithActions False ''Archive ) 37 | 38 | $(devShow ''ArchiveAction) 39 | 40 | $(devNFData ''Archive) 41 | 42 | zipInfo :: FormatInfo Archive ArchiveAction 43 | zipInfo = def 44 | { encode = fromArchive 45 | , random = arbitrary 46 | , value = show 47 | , actions = Just $ def 48 | { randomActions = arbitrary 49 | , shrinkActions = shrinkArchiveAction 50 | , performActions = performArchiveAction } 51 | , ext = "zip" 52 | } 53 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Code.C where 7 | 8 | import Data.Default 9 | 10 | import Language.C 11 | import Language.C.Data.Position 12 | import Language.C.Data.Ident 13 | 14 | import Test.QuickCheck 15 | import Control.Monad 16 | import Control.DeepSeq 17 | import Control.Monad.Trans 18 | import Control.Monad.Trans.State 19 | import Data.List 20 | 21 | import Test.QuickFuzz.Derive.Arbitrary 22 | import Test.QuickFuzz.Derive.Fixable 23 | import Test.QuickFuzz.Derive.NFData 24 | import Test.QuickFuzz.Derive.Show 25 | import Test.QuickFuzz.Derive.Mutation 26 | 27 | import Test.QuickFuzz.Gen.FormatInfo 28 | import Test.QuickFuzz.Gen.Base.ByteString 29 | import Test.QuickFuzz.Gen.Base.String 30 | 31 | import qualified Data.ByteString.Lazy.Char8 as L8 32 | import qualified Data.ByteString as BS 33 | 34 | instance NFData Position where 35 | rnf x = () 36 | 37 | --data CCode = CCode (CTranslationUnit NodeInfo) 38 | --unCCode (CCode x) = x 39 | 40 | devArbitrary ''CTranslUnit 41 | devNFData ''CTranslationUnit 42 | devMutation ''CTranslUnit 43 | 44 | decodeC x = either undefined id $ parseC (L8.toStrict x) (initPos "") 45 | 46 | cInfo :: FormatInfo CTranslUnit NoActions 47 | cInfo = def 48 | { -- encode = L8.pack . concat . (map show) . (map pretty) 49 | encode = L8.pack . show . pretty 50 | , decode = decodeC 51 | , mutate = mutt 52 | , random = arbitrary 53 | , value = show 54 | , ext = "c" 55 | } 56 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document/PDF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Document.PDF where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck 11 | 12 | import qualified Data.ByteString.Lazy.Char8 as L8 13 | import Data.DeriveTH 14 | import Control.DeepSeq 15 | 16 | import Graphics.EasyRender 17 | import Graphics.EasyRender.Internal 18 | 19 | import Test.QuickFuzz.Derive.Actions 20 | import Test.QuickFuzz.Derive.Arbitrary 21 | import Test.QuickFuzz.Derive.Show 22 | import Test.QuickFuzz.Gen.FormatInfo 23 | import Test.QuickFuzz.Gen.Base.ByteString 24 | import Test.QuickFuzz.Gen.Base.String 25 | 26 | $(devActions ["Graphics.EasyRender"] ''Draw True [''()] []) 27 | $(devArbitrary ''DrawAction) 28 | $(devShow ''DrawAction) 29 | 30 | instance Arbitrary (Draw ()) where 31 | arbitrary = performDrawAction <$> arbitrary 32 | 33 | instance NFData (Draw ()) where 34 | rnf _ = () 35 | 36 | -- $(devActions ["Graphics.EasyRender"] ''Document True [''() ]) 37 | -- $(devArbitrary ''DocumentAction) 38 | -- $(devArbitraryWithActions True ''Document) 39 | -- $(devShow ''DocumentAction) 40 | 41 | pdfInfo :: FormatInfo (Draw()) [DrawAction] 42 | pdfInfo = def 43 | { encode = L8.pack . render_string Format_PDF . newpage 1024 1024 44 | , random = arbitrary 45 | , actions = Just $ def 46 | { randomActions = arbitrary 47 | , shrinkActions = shrinkActionList shrinkDrawAction 48 | , performActions = performDrawAction } 49 | , ext = "pdf" 50 | } 51 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/GLSL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Code.GLSL where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck hiding (Discard) 11 | import Control.DeepSeq 12 | import Control.Monad 13 | import Control.Monad.Trans 14 | import Control.Monad.Trans.State 15 | import Data.List 16 | 17 | import Data.ByteString.Lazy.Char8 as L8 18 | import Data.ByteString.Lazy as L 19 | import Data.Text (unpack) 20 | import Data.Text.Encoding (decodeUtf8) 21 | 22 | import Text.PrettyPrint.HughesPJClass 23 | 24 | import Language.GLSL.Syntax 25 | import Language.GLSL.Parser 26 | import Language.GLSL.Pretty 27 | 28 | import Test.QuickFuzz.Derive.Arbitrary 29 | import Test.QuickFuzz.Derive.Fixable 30 | import Test.QuickFuzz.Derive.Show 31 | import Test.QuickFuzz.Derive.NFData 32 | import Test.QuickFuzz.Derive.Mutation 33 | import Test.QuickFuzz.Gen.FormatInfo 34 | import Test.QuickFuzz.Gen.Base.ByteString 35 | import Test.QuickFuzz.Gen.Base.String 36 | 37 | import qualified Data.ByteString.Lazy.Char8 as L8 38 | 39 | devArbitrary ''TranslationUnit 40 | devMutation ''TranslationUnit 41 | devNFData ''TranslationUnit 42 | 43 | decodeglsl x = either undefined id $ parse (Data.Text.unpack $ decodeUtf8 $ L.toStrict x) 44 | 45 | glslInfo :: FormatInfo TranslationUnit NoActions 46 | glslInfo = def 47 | { encode = L8.pack . render . option . Just 48 | , decode = decodeglsl 49 | , mutate = mutt 50 | , random = arbitrary 51 | , value = show 52 | , ext = "glsl" 53 | } 54 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image/Png.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Image.Png where 7 | 8 | import Data.Default 9 | 10 | import qualified Data.Binary 11 | 12 | import Codec.Picture.Png 13 | import Codec.Picture.Png.Type 14 | import Codec.Picture.Png.Export 15 | import Codec.Picture.Metadata 16 | import Codec.Picture.ColorQuant 17 | 18 | import Test.QuickCheck 19 | import Control.Monad 20 | import Control.DeepSeq 21 | import Control.Monad.Trans 22 | import Control.Monad.Trans.State 23 | import Data.List 24 | import Data.Monoid 25 | 26 | import Test.QuickFuzz.Derive.Arbitrary 27 | import Test.QuickFuzz.Derive.Mutation 28 | import Test.QuickFuzz.Gen.FormatInfo 29 | import Test.QuickFuzz.Derive.Show 30 | import Test.QuickFuzz.Derive.NFData 31 | import Test.QuickFuzz.Gen.FormatInfo 32 | import Test.QuickFuzz.Gen.Base.ByteString 33 | import Test.QuickFuzz.Gen.Base.String 34 | import Test.QuickFuzz.Gen.Base.Image 35 | 36 | import qualified Data.ByteString.Lazy as L 37 | 38 | devArbitrary ''PngRawImage 39 | devMutation ''PngRawImage 40 | devShow ''PngRawImage 41 | devNFData ''PngRawImage 42 | 43 | pngencode :: PngRawImage -> L.ByteString 44 | pngencode = Data.Binary.encode 45 | 46 | pngdecode :: L.ByteString -> PngRawImage 47 | pngdecode = Data.Binary.decode 48 | 49 | pngInfo :: FormatInfo PngRawImage NoActions 50 | pngInfo = def 51 | { encode = pngencode 52 | , decode = pngdecode 53 | , random = arbitrary 54 | , mutate = mutt 55 | , value = show 56 | , ext = "png" 57 | } 58 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Global.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Global where 2 | 3 | import System.IO.Unsafe (unsafePerformIO) 4 | 5 | import Control.Exception 6 | import Data.Global 7 | import Data.IORef 8 | import Data.Maybe 9 | 10 | type FreqVar = IORef [Int] 11 | type FreqState = IORef [(String, FreqVar)] 12 | 13 | freqs :: FreqState 14 | freqs = declareIORef "freqs" [] 15 | 16 | declareFreqVar var = (var, declareIORef var ([] :: [Int])) 17 | 18 | readFreqFile :: IO String 19 | readFreqFile = do 20 | strOrExc <- try $ readFile "freqs.txt" 21 | case (strOrExc :: Either IOError String) of 22 | Left _ -> return "[]" 23 | Right contents -> return contents 24 | 25 | initFreqs :: IO () 26 | initFreqs = do 27 | contents <- readFreqFile 28 | let freqMap = (read contents) :: [(String, [Int])] 29 | 30 | updateVar freqs (map (\(var, xs) -> declareFreqVar var) freqMap) 31 | 32 | freqs <- readIORef freqs 33 | mapM_ (\(var, xs) -> setFreqs var xs freqs ) freqMap 34 | 35 | 36 | getFreqs :: String -> [Int] 37 | getFreqs var = unsafePerformIO $ do 38 | freqs <- readIORef freqs 39 | --print var 40 | case (lookup var freqs) of 41 | Just x -> readIORef x 42 | Nothing -> return (repeat 1) 43 | 44 | setFreqs :: String -> [Int] -> [(String, FreqVar)] -> IO () 45 | setFreqs var xs freqs = updateVar (fromJust (lookup var freqs)) xs 46 | 47 | updateVar :: (IORef a) -> a -> IO () 48 | updateVar v xs = atomicModifyIORef v f 49 | where f _ = (xs, ()) 50 | 51 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/Js.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Code.Js where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck 11 | import Control.DeepSeq 12 | import Control.Monad 13 | import Control.Monad.Trans 14 | import Control.Monad.Trans.State 15 | import Data.List 16 | --import Text.Parsec.Pos 17 | 18 | import Data.ByteString.Lazy.Char8 as L8 19 | import Data.ByteString.Lazy as L 20 | import Data.Text (unpack) 21 | import Data.Text.Encoding (decodeUtf8) 22 | 23 | import Language.ECMAScript3.PrettyPrint 24 | import Language.ECMAScript3.Syntax 25 | import Language.ECMAScript3.Parser 26 | 27 | import Test.QuickFuzz.Derive.Arbitrary 28 | import Test.QuickFuzz.Derive.Fixable 29 | import Test.QuickFuzz.Derive.Show 30 | import Test.QuickFuzz.Derive.NFData 31 | import Test.QuickFuzz.Derive.Mutation 32 | import Test.QuickFuzz.Gen.FormatInfo 33 | import Test.QuickFuzz.Gen.Base.ByteString 34 | import Test.QuickFuzz.Gen.Base.String 35 | 36 | import qualified Data.ByteString.Lazy.Char8 as L8 37 | 38 | type Js = JavaScript SourcePos 39 | devArbitrary ''Js 40 | devMutation ''Js 41 | devNFData ''JavaScript 42 | 43 | instance NFData SourcePos where 44 | rnf x = () 45 | 46 | --devNFData ''SourcePos 47 | 48 | decode' x = either undefined id $ parseFromString (Data.Text.unpack $ decodeUtf8 $ L.toStrict x) 49 | 50 | jsInfo :: FormatInfo Js NoActions 51 | jsInfo = def 52 | { encode = L8.pack . show . prettyPrint 53 | , decode = decode' 54 | , mutate = mutt 55 | , random = arbitrary 56 | , value = show 57 | , ext = "js" 58 | } 59 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Code/Evm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Test.QuickFuzz.Gen.Code.Evm (evmInfo) where 8 | 9 | import Data.Default 10 | import Prelude hiding (GT,LT,EQ) 11 | 12 | import Test.QuickCheck 13 | import Control.DeepSeq 14 | import Control.Monad 15 | import Control.Monad.Trans 16 | import Control.Monad.Trans.State 17 | import Data.List 18 | 19 | import Data.ByteString as BS 20 | import Data.ByteString.Lazy as L 21 | 22 | import Blockchain.Data.Code 23 | import Blockchain.VM.Code 24 | import Blockchain.VM.Opcodes 25 | import Blockchain.Util 26 | import Blockchain.ExtWord 27 | 28 | import Test.QuickFuzz.Derive.Arbitrary 29 | import Test.QuickFuzz.Derive.Fixable 30 | import Test.QuickFuzz.Derive.Show 31 | import Test.QuickFuzz.Derive.NFData 32 | import Test.QuickFuzz.Derive.Mutation 33 | import Test.QuickFuzz.Gen.FormatInfo 34 | import Test.QuickFuzz.Gen.Base.ByteString 35 | import Test.QuickFuzz.Gen.Base.String 36 | 37 | type EvmBytecode = [Operation] 38 | 39 | devArbitrary ''EvmBytecode 40 | devShow ''EvmBytecode 41 | devNFData ''EvmBytecode 42 | 43 | disasmBSAt :: BS.ByteString -> Word256 -> Int -> [Operation] 44 | disasmBSAt "" _ _ = [] 45 | disasmBSAt _ _ 0 = [] 46 | disasmBSAt bs base limit = 47 | op : disasmBSAt (safeDrop next bs) (base + next) (limit - 1) 48 | where 49 | (op, next) = getOperationAt' bs 0 50 | 51 | decode' x = disasmBSAt (L.toStrict x) 0 10240 52 | 53 | evmInfo :: FormatInfo EvmBytecode NoActions 54 | evmInfo = def 55 | { encode = L.fromStrict . codeBytes . compile 56 | , decode = decode' 57 | , mutate = mutt 58 | , random = arbitrary 59 | , value = show 60 | , ext = "evm" 61 | } 62 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Main where 3 | 4 | import Control.Exception 5 | import System.Environment 6 | import Data.List 7 | 8 | import Args 9 | import Formats 10 | import Utils 11 | 12 | import DeriveDispatcher 13 | 14 | import Run.GenTest 15 | import Run.MutTest 16 | import Run.Gen 17 | import Run.Exec 18 | import Run.Shrink 19 | import Run.List 20 | import Run.Serve 21 | 22 | import Test.QuickFuzz.Global 23 | 24 | -- |Print unsupported file format error message 25 | unsupported :: String -> IO () 26 | unsupported fmt = do 27 | qf <- getProgName 28 | error $ "file format '" ++ fmt ++ "' is not supported.\n" ++ 29 | "See '" ++ qf ++ " list' to print the available formats." 30 | 31 | -- |Template Haskell dispatcher derivations 32 | devDispatcher 'GenTest 'runGenTest 33 | devDispatcher 'MutTest 'runMutTest 34 | devDispatcher 'Gen 'runGen 35 | devDispatcher 'Exec 'runExec 36 | devDispatcher 'Shrink 'runShrink 37 | devDispatcher 'Serve 'runServe 38 | 39 | -- |Subcommands dispatcher 40 | quickfuzz :: QFCommand -> IO () 41 | quickfuzz cmd@(GenTest {}) = dispatchGenTest cmd 42 | quickfuzz cmd@(MutTest {}) = dispatchMutTest cmd 43 | quickfuzz cmd@(Gen {}) = dispatchGen cmd 44 | quickfuzz cmd@(Exec {}) = dispatchExec cmd 45 | quickfuzz cmd@(Shrink {}) = dispatchShrink cmd 46 | quickfuzz cmd@(Serve {}) = dispatchServe cmd 47 | quickfuzz List = runList 48 | 49 | 50 | 51 | -- |Pretty print error messages 52 | printException :: SomeException -> IO () 53 | printException e = do 54 | restoreTerm 55 | qf <- getProgName 56 | putStrLn $ qf ++ ": " ++ show e 57 | 58 | main :: IO () 59 | main = handle printException $ do 60 | initFreqs 61 | command <- parseCommand 62 | cleanTerm 63 | runApp command (\cmd -> sanitize cmd >>= quickfuzz) 64 | restoreTerm 65 | -------------------------------------------------------------------------------- /app/Run/Serve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module Run.Serve (runServe) where 3 | 4 | import Prelude hiding (writeFile) 5 | import Data.ByteString.Lazy (writeFile, toStrict) 6 | 7 | import Control.Monad 8 | import Control.Exception 9 | 10 | import Network hiding (accept, sClose) 11 | import Network.Socket hiding (send, sendTo, recv, recvFrom) 12 | import Network.Socket.ByteString (send, sendTo, recv, recvFrom, sendAll) 13 | import Control.Concurrent (forkIO) 14 | import System.IO (hSetBuffering, stdout, BufferMode(..)) 15 | 16 | import Test.QuickCheck (generate, resize, infiniteListOf) 17 | import Test.QuickFuzz.Gen.FormatInfo 18 | 19 | import Args 20 | import Debug 21 | import Exception 22 | 23 | 24 | --serve :: PortNumber -> [ByteString] -> IO () 25 | serve port xs = withSocketsDo $ do 26 | sock <- listenOn $ PortNumber port 27 | serveLoop sock xs 28 | 29 | serveLoop sock (x:xs) = do 30 | putStr "." 31 | (conn, _) <- accept sock 32 | forkIO $ body conn 33 | serveLoop sock xs 34 | where 35 | body c = do sendAll c (toStrict x) 36 | close c 37 | 38 | serveLoop _ [] = error "Empty list!" 39 | 40 | toPortNumber :: Int -> PortNumber 41 | toPortNumber = fromInteger . toInteger 42 | 43 | runServe :: QFCommand -> FormatInfo base actions-> IO () 44 | runServe info fmt = do 45 | hSetBuffering stdout NoBuffering 46 | putStrLn $ "Serving " ++ (format info) ++ "files through port " ++ (show (port info)) 47 | xs <- generate $ infiniteListOf (random fmt) 48 | serve (toPortNumber (port info)) (map (encode fmt) xs) 49 | 50 | --mkName <- nameMaker fmt 51 | --createDirectoryIfMissing True (outDir cmd) 52 | --forM_ [1..(genQty cmd)] $ \n -> do 53 | --val <- generate $ resize (linear cmd n) (random fmt) 54 | --write (outDir cmd mkName n) (encode fmt val) 55 | --printStep cmd mkName n 56 | -------------------------------------------------------------------------------- /app/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Process where 4 | 5 | import Prelude hiding (putStrLn) 6 | 7 | import Control.Monad 8 | import Data.ByteString.Lazy.Char8 9 | 10 | import System.Process.ByteString.Lazy (readProcessWithExitCode) 11 | import System.Process (rawSystem) 12 | import System.Exit 13 | import System.FilePath 14 | import System.IO hiding (putStrLn) 15 | import System.IO.Silently 16 | import System.Random 17 | 18 | import Fuzzers 19 | import Exception 20 | 21 | -- |Check if a shell exit code represents a failed execution 22 | hasFailed :: ExitCode -> Bool 23 | hasFailed (ExitFailure n) = n < 0 || (n > 128 && n < 143) 24 | hasFailed ExitSuccess = False 25 | 26 | -- |A shell command consists in a filepath to the executable 27 | -- and a list of arguments 28 | type ShellCommand = (FilePath, [String]) 29 | 30 | 31 | -- |Execute a shell command, as faster as possible. 32 | -- If a verbose flag is set, the process stdout is not silenced. 33 | execute :: Bool -> ShellCommand -> IO ExitCode 34 | execute verbose (exe, args) = addVerbosity $ rawSystem exe args 35 | where addVerbosity | verbose = id 36 | | otherwise = hSilence [stdout, stderr] 37 | 38 | 39 | -- |Execute a shell command passing it a bytestring as stdin 40 | -- and returning its exit code. 41 | executeFromStdin :: Bool -> ShellCommand -> ByteString -> IO ExitCode 42 | executeFromStdin verbose (exe, args) bs = do 43 | (exitCode, stdout, stderr) <- readProcessWithExitCode exe args bs 44 | when verbose $ putStrLn stdout 45 | return exitCode 46 | 47 | -- |Fuzz a bytestring into another using a given fuzzer. 48 | -- If something fails, return the input unaltered 49 | fuzz :: Fuzzer -> ByteString -> Int -> IO ByteString 50 | fuzz fuzzer bs seed = do 51 | let (exe, args) = getFuzzerCommand fuzzer seed 52 | (_,fuzzed,_) <- readProcessWithExitCode exe args bs 53 | return fuzzed 54 | 55 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document/Html.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | module Test.QuickFuzz.Gen.Document.Html where 8 | 9 | import Data.Default 10 | 11 | import Test.QuickCheck hiding (shrink) 12 | 13 | import qualified Data.ByteString.Lazy as L 14 | import qualified Data.ByteString.Lazy.Char8 as L8 15 | import qualified Data.ByteString.Char8 as C8 16 | 17 | import Control.DeepSeq 18 | import Data.DeriveTH 19 | 20 | import Test.QuickFuzz.Derive.Actions 21 | import Test.QuickFuzz.Derive.Arbitrary 22 | import Test.QuickFuzz.Derive.Show 23 | import Test.QuickFuzz.Gen.FormatInfo hiding (value) 24 | import Test.QuickFuzz.Gen.Base.ByteString 25 | import Test.QuickFuzz.Gen.Base.String 26 | 27 | import Text.Blaze.Internal 28 | import Text.Blaze.Html 29 | import Text.Blaze.Html5 30 | import Text.Blaze.Html5.Attributes 31 | import Text.Blaze.Html.Renderer.String 32 | 33 | 34 | $(devActions ["Text.Blaze.Html5.Attributes"] ''Attribute False [] []) 35 | $(devArbitrary ''AttributeAction) 36 | $(devArbitraryWithActions False ''Attribute) 37 | -- $(devShow ''AttributeAction) 38 | 39 | instance (Show Attribute) where 40 | show _ = "" 41 | 42 | $(devActions ["Text.Blaze.Html5"] ''Html True [''Html, ''String] []) 43 | $(devArbitrary ''HtmlAction) 44 | $(devArbitraryWithActions True ''Html) 45 | 46 | $(derive makeShow ''HtmlAction) 47 | -- $(devShow ''HtmlAction) 48 | 49 | instance Show Html where 50 | show _ = "" 51 | 52 | instance NFData Html where 53 | rnf _ = () 54 | 55 | htmlInfo :: FormatInfo Html [HtmlAction] 56 | htmlInfo = def 57 | { encode = L8.pack . renderHtml 58 | , random = arbitrary 59 | , actions = Just $ def 60 | { randomActions = arbitrary 61 | , shrinkActions = shrinkActionList shrinkHtmlAction 62 | , performActions = performHtmlAction } 63 | , ext = "html" 64 | } 65 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document/Xml.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Document.Xml where 7 | 8 | import Data.Default 9 | 10 | import Test.QuickCheck 11 | 12 | import qualified Data.ByteString.Lazy as L 13 | import qualified Data.ByteString.Lazy.Char8 as L8 14 | import qualified Data.ByteString.Char8 as C8 15 | 16 | import Data.DeriveTH 17 | import Control.DeepSeq 18 | 19 | import Test.QuickFuzz.Derive.Actions 20 | import Test.QuickFuzz.Derive.Arbitrary 21 | import Test.QuickFuzz.Derive.Show 22 | import Test.QuickFuzz.Gen.FormatInfo 23 | import Test.QuickFuzz.Gen.Base.ByteString 24 | import Test.QuickFuzz.Gen.Base.String 25 | 26 | import Data.Text hiding (map) 27 | import Data.Monoid 28 | import Blaze.ByteString.Builder 29 | import Text.XML.Generator 30 | 31 | type XmlElem = Xml Elem 32 | type XmlDoc = Xml Doc 33 | 34 | $(devActions ["Text.XML.Generator"] ''XmlElem False [''XmlElem, ''Text] ['xtextRaw]) 35 | $(devArbitrary ''XmlElemAction) 36 | -- $(devArbitraryWithActions False ''XmlElem) 37 | $(devShow ''XmlElemAction) 38 | 39 | instance Arbitrary XmlElem where 40 | arbitrary = do 41 | elems <- arbitrary 42 | return $ xelems (map performXmlElemAction elems) 43 | 44 | 45 | instance Arbitrary XmlDoc where 46 | arbitrary = do 47 | elems <- arbitrary 48 | return $ doc defaultDocInfo (xelems elems) 49 | 50 | instance (Show XmlDoc) where 51 | show _ = "" 52 | 53 | instance NFData XmlDoc where 54 | rnf _ = () 55 | 56 | 57 | xmlInfo :: FormatInfo XmlDoc XmlElemAction 58 | xmlInfo = def 59 | { encode = xrender 60 | , random = arbitrary 61 | , actions = Just $ def 62 | { randomActions = arbitrary 63 | , shrinkActions = shrinkXmlElemAction 64 | , performActions = doc defaultDocInfo . performXmlElemAction 65 | , valueActions = show } 66 | , ext = "xml" 67 | } 68 | 69 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # Override default flag values for local packages and extra-deps 2 | flags: 3 | QuickFuzz: 4 | debug : false 5 | image : false 6 | arch : false 7 | doc : false 8 | code : false 9 | media : false 10 | pki : false 11 | bnfc : false 12 | all : false 13 | 14 | extra-package-dbs: [] 15 | 16 | packages: 17 | - location: https://github.com/CIFASIS/megadeth/archive/master.zip 18 | extra-dep: true 19 | 20 | - location: https://bitbucket.org/jmg/global-variables/get/6bbea1933b8e.zip 21 | extra-dep: true 22 | 23 | - location: https://github.com/agustinmista/ArgParser/archive/master.zip 24 | extra-dep: true 25 | 26 | - location: https://github.com/agustinmista/GhcMod/archive/master.zip 27 | extra-dep: true 28 | 29 | # Media 30 | 31 | - location: 32 | git: https://bitbucket.org/robertmassaioli/riff.git 33 | commit: 01734c4d205c642c471fd3ba76c2d492605f39c8 34 | extra-dep: true 35 | 36 | - location: https://github.com/CIFASIS/wavy/archive/master.zip 37 | extra-dep: true 38 | 39 | # Code 40 | 41 | - location: https://github.com/remyoudompheng/hs-language-go/archive/master.zip 42 | extra-dep: true 43 | 44 | # PKI 45 | 46 | - location: https://github.com/CIFASIS/hs-certificate-x509/archive/master.zip 47 | extra-dep: true 48 | 49 | - location: https://github.com/CIFASIS/hs-asn1-encoding/archive/master.zip 50 | extra-dep: true 51 | 52 | # Imgs 53 | 54 | - location: https://github.com/CIFASIS/Juicy.Pixels/archive/master.zip 55 | extra-dep: true 56 | 57 | - '.' 58 | 59 | extra-deps: 60 | - QuickCheck-2.9.2 61 | - derive-2.5.26 62 | - vector-0.10.12.3 63 | - process-extras-0.4.1.4 64 | - generic-deriving-1.10.0 65 | - language-python-0.5.4 66 | - global-variables-1.0.1.0 67 | - svg-tree-0.6 68 | - language-go-0.9 69 | - easyrender-0.1.1.1 70 | - superdoc-0.1.2.4 71 | - bytestring-0.10.8.1 72 | - language-css-0.0.3 73 | - language-lua-0.10.0 74 | - language-glsl-0.2.1 75 | - ethereum-analyzer-deps-1.3.0 76 | - global-lock-0.1 77 | - BNFC-2.8.1 78 | 79 | explicit-setup-deps: 80 | ! '*': true 81 | 82 | resolver: lts-5.9 83 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image/Jpeg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Image.Jpeg where 7 | 8 | import Data.Default 9 | 10 | import qualified Data.Binary 11 | 12 | import Codec.Picture.Jpg 13 | import Codec.Picture.Jpg.Types 14 | import Codec.Picture.Tiff.Types 15 | import Codec.Picture.Jpg.DefaultTable 16 | 17 | import Test.QuickCheck 18 | import Control.Monad 19 | import Control.DeepSeq 20 | import Control.Monad.Trans 21 | import Control.Monad.Trans.State 22 | import Data.List 23 | import Data.Monoid 24 | import Data.Word(Word8, Word16, Word32) 25 | 26 | import Test.QuickFuzz.Derive.Arbitrary 27 | import Test.QuickFuzz.Derive.Mutation 28 | import Test.QuickFuzz.Derive.Actions 29 | import Test.QuickFuzz.Derive.Show 30 | import Test.QuickFuzz.Derive.NFData 31 | 32 | import Test.QuickFuzz.Gen.FormatInfo 33 | import Test.QuickFuzz.Gen.Base.ByteString 34 | import Test.QuickFuzz.Gen.Base.String 35 | import Test.QuickFuzz.Gen.Base.Image 36 | import Test.QuickFuzz.Gen.Base.Vector 37 | 38 | import qualified Data.ByteString.Lazy as L 39 | 40 | $(devActions ["Codec.Picture.Jpg.DefaultTable"] ''HuffmanTree False [] []) 41 | $(devArbitrary ''HuffmanTreeAction) 42 | $(devArbitraryWithActions False ''HuffmanTree) 43 | 44 | $(devActions ["Codec.Picture.Jpg.DefaultTable"] ''HuffmanPackedTree False [] []) 45 | $(devArbitrary ''HuffmanPackedTreeAction) 46 | $(devArbitraryWithActions False ''HuffmanPackedTree) 47 | 48 | $(devActions ["Codec.Picture.Jpg.DefaultTable"] ''HuffmanTable False [] []) 49 | $(devArbitrary ''HuffmanTableAction) 50 | $(devArbitraryWithActions False ''HuffmanTable) 51 | 52 | devArbitrary ''JpgImage 53 | devMutation ''JpgImage 54 | devShow ''JpgImage 55 | devNFData ''JpgImage 56 | 57 | jpegencode :: JpgImage -> L.ByteString 58 | jpegencode = Data.Binary.encode 59 | 60 | jpegdecode :: L.ByteString -> JpgImage 61 | jpegdecode = Data.Binary.decode 62 | 63 | jpegInfo :: FormatInfo JpgImage NoActions 64 | jpegInfo = def 65 | { encode = jpegencode 66 | , decode = jpegdecode 67 | , mutate = mutt 68 | , random = arbitrary 69 | , value = show 70 | , ext = "jpg" 71 | } 72 | -------------------------------------------------------------------------------- /app/Formats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, CPP #-} 2 | module Formats 3 | ( formats 4 | ) where 5 | 6 | import Test.QuickFuzz.Gen.FormatInfo 7 | 8 | -- Base 9 | import Test.QuickFuzz.Gen.Base 10 | 11 | -- Document 12 | #ifdef DOC 13 | import Test.QuickFuzz.Gen.Document 14 | #endif 15 | 16 | -- Archives 17 | #ifdef ARCH 18 | import Test.QuickFuzz.Gen.Archive 19 | #endif 20 | 21 | -- Media 22 | #ifdef MEDIA 23 | import Test.QuickFuzz.Gen.Media 24 | #endif 25 | 26 | -- Media 27 | #ifdef IMAGE 28 | import Test.QuickFuzz.Gen.Image 29 | #endif 30 | 31 | -- Code 32 | #ifdef CODE 33 | import Test.QuickFuzz.Gen.Code 34 | #endif 35 | 36 | -- PKI 37 | #ifdef PKI 38 | import Test.QuickFuzz.Gen.Pki 39 | #endif 40 | 41 | -- Network 42 | #ifdef NET 43 | import Test.QuickFuzz.Gen.Network 44 | #endif 45 | 46 | -- BNFC 47 | #ifdef BNFC 48 | import Test.QuickFuzz.Gen.Bnfc 49 | #endif 50 | 51 | 52 | formats = [ 53 | 54 | -- Archives 55 | #ifdef ARCH 56 | ("tar", 'tarInfo), 57 | ("zip", 'zipInfo), 58 | #endif 59 | 60 | -- Media 61 | #ifdef MEDIA 62 | ("wav", 'wavInfo), 63 | #endif 64 | 65 | -- Document 66 | #ifdef DOC 67 | ("html", 'htmlInfo), 68 | ("css", 'cssInfo), 69 | ("pdf", 'pdfInfo), 70 | ("ps", 'psInfo), 71 | ("eps", 'epsInfo), 72 | ("xml", 'xmlInfo), 73 | #endif 74 | 75 | -- Image 76 | #ifdef IMAGE 77 | ("svg", 'svgInfo), 78 | ("png", 'pngInfo), 79 | ("gif", 'gifInfo), 80 | ("tiff", 'tiffInfo), 81 | ("jpeg", 'jpegInfo), 82 | ("tga", 'tgaInfo), 83 | #endif 84 | 85 | -- Source Code 86 | #ifdef CODE 87 | ("c", 'cInfo), 88 | ("js", 'jsInfo), 89 | ("py", 'pyInfo), 90 | ("go", 'goInfo), 91 | ("lua", 'luaInfo), 92 | ("evm", 'evmInfo), 93 | ("glsl", 'glslInfo), 94 | #endif 95 | 96 | -- PKI 97 | #ifdef PKI 98 | ("asn1", 'asn1Info), 99 | ("crl", 'crlInfo), 100 | ("x509", 'x509Info), 101 | #endif 102 | 103 | 104 | -- Network 105 | #ifdef NET 106 | ("http", 'httpResponseInfo), 107 | #endif 108 | 109 | -- Bnfc 110 | #ifdef BNFC 111 | ("bnfc", 'bnfcInfo), 112 | #endif 113 | 114 | -- Base 115 | ("regex", 'regexInfo) 116 | 117 | ] 118 | 119 | 120 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image/Tiff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Image.Tiff where 7 | 8 | import Data.Default 9 | 10 | import qualified Data.Binary 11 | import Data.Binary.Put( runPut ) 12 | 13 | import Codec.Picture.Tiff 14 | import Codec.Picture.Tiff.Types 15 | import Codec.Picture.Types 16 | import Codec.Picture.Metadata.Exif 17 | import Codec.Picture.Metadata 18 | import Codec.Picture.VectorByteConversion( toByteString ) 19 | 20 | import Test.QuickCheck 21 | import Control.Monad 22 | import Control.DeepSeq 23 | import Control.Monad.Trans 24 | import Control.Monad.Trans.State 25 | import Data.List 26 | import Data.Monoid 27 | 28 | import Test.QuickFuzz.Derive.Arbitrary 29 | import Test.QuickFuzz.Derive.NFData 30 | import Test.QuickFuzz.Derive.Show 31 | 32 | import Test.QuickFuzz.Gen.FormatInfo 33 | import Test.QuickFuzz.Gen.Base.ByteString 34 | import Test.QuickFuzz.Gen.Base.String 35 | import Test.QuickFuzz.Gen.Base.Image 36 | import Test.QuickFuzz.Gen.Base.Vector 37 | 38 | import qualified Data.ByteString.Lazy as L 39 | 40 | data TiffImage = Tiff0 (TiffInfo, Image Pixel8) 41 | -- | Tiff1 (Image PixelCMYK16) 42 | -- | Tiff2 (Image PixelYA8) 43 | -- | Tiff3 (Image PixelRGBA8) 44 | -- | Tiff4 (Image PixelYCbCr8) 45 | 46 | 47 | instance Arbitrary TiffHeader where 48 | arbitrary = return $ TiffHeader {hdrEndianness = EndianBig, hdrOffset = 0} 49 | 50 | devArbitrary ''TiffImage 51 | devShow ''TiffImage 52 | devNFData ''TiffImage 53 | 54 | tiffencode :: TiffImage -> L.ByteString 55 | tiffencode (Tiff0 (hdr, img)) = runPut $ putP rawPixelData hdr 56 | where rawPixelData = toByteString $ imageData img 57 | 58 | --tiffencode (Tiff1 img) = encodeTiff img 59 | --tiffencode (Tiff2 img) = encodeTiff img 60 | --tiffencode (Tiff3 img) = encodeTiff img 61 | --tiffencode (Tiff4 img) = encodeTiff img 62 | 63 | tiffInfo :: FormatInfo TiffImage NoActions 64 | tiffInfo = def 65 | { encode = tiffencode 66 | , random = arbitrary 67 | , value = show 68 | , ext = "tiff" 69 | } 70 | -------------------------------------------------------------------------------- /app/Utils/Console.hs: -------------------------------------------------------------------------------- 1 | module Utils.Console where 2 | 3 | import Data.Maybe 4 | import Data.List 5 | import Data.List.Split 6 | 7 | import System.FilePath 8 | import System.Environment 9 | 10 | import Control.Concurrent 11 | import Control.Exception 12 | import System.IO.Error 13 | import System.Posix.Signals 14 | import System.Console.ANSI 15 | 16 | import Test.QuickFuzz.Gen.FormatInfo 17 | import Args 18 | 19 | import Utils.Unique 20 | 21 | -- | Generates the shell command needeed to execute the target program, 22 | -- inserting a user provided constant output filename, or generating a unique 23 | -- one otherwise. 24 | prepareCli :: QFCommand -> FormatInfo base actions -> IO ((FilePath, [String]), String) 25 | prepareCli cmd fmt 26 | | usesOutFile cmd = do 27 | let filename = outDir cmd fromJust (outFile cmd) 28 | return (mkRawCli (cli cmd) filename fmt, filename) 29 | | otherwise = do 30 | filename <- testName fmt 31 | return (mkRawCli (cli cmd) filename fmt, filename) 32 | 33 | mkRawCli cli fname fmt = (head tokens, tail tokens) 34 | where tokens = wordsBy (==' ') $ replace fname $ cli 35 | replace fname = intercalate fname . splitOn inputToken 36 | 37 | 38 | -- |Add some behavior when a sigterm is invoked by the user 39 | handleSigInt :: IO () -> IO () -> IO () 40 | handleSigInt cleaner action = do 41 | tid <- myThreadId 42 | let interruptedError = userError "Operation interrupted by the user" 43 | handler = cleaner >> throwTo tid (toException interruptedError) 44 | installHandler keyboardSignal (Catch handler) Nothing 45 | action 46 | 47 | -- |Console printers and helpers 48 | printTestStep n = do 49 | clearLine 50 | putStrLn $ show n ++ " random files tested." 51 | cursorUpLine 1 52 | 53 | printGenStep n = do 54 | clearLine 55 | putStrLn $ show n ++ " files generated." 56 | cursorUpLine 1 57 | 58 | printShrinkStep size = do 59 | -- clearLine 60 | putStrLn $ "Testing shrink of size " ++ show size 61 | -- cursorUpLine 1 62 | 63 | printShrinkingFinished = do 64 | putStrLn "Shrinking finished" 65 | 66 | cleanTerm = clearLine >> hideCursor 67 | restoreTerm = clearLine >> showCursor 68 | printFinished = cursorDownLine 1 >> putStrLn "Finished!" >> showCursor 69 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | general: 2 | branches: 3 | only: 4 | - master 5 | 6 | machine: 7 | environment: 8 | PATH: $PATH:/home/ubuntu/.local/bin 9 | 10 | dependencies: 11 | cache_directories: 12 | - "~/.stack" 13 | - "~/.cabal" 14 | pre: 15 | - sudo apt-key adv --keyserver hkp://keyserver.ubuntu.com:80 --recv-keys 575159689BEFB442 16 | - echo 'deb http://download.fpcomplete.com/ubuntu trusty main'|sudo tee /etc/apt/sources.list.d/fpco.list 17 | - sudo apt-get update && sudo apt-get install stack -y 18 | - sudo apt-get install zlib1g-dev libgmp-dev 19 | - sudo apt-get install zzuf 20 | - git clone https://github.com/CIFASIS/radamsa; cd radamsa; git pull; make install DESTDIR=$HOME/.local PREFIX="" 21 | - sudo apt-get install binutils-dev libunwind8-dev 22 | - git clone https://github.com/CIFASIS/honggfuzz; cd honggfuzz; make; cp ./honggfuzz $HOME/.local/bin 23 | override: 24 | - stack setup 25 | - rm -rf $(stack path --dist-dir) $(stack path --local-install-root) 26 | - stack build --only-dependencies --flag QuickFuzz:image 27 | - stack build --only-dependencies --flag QuickFuzz:pki 28 | - stack build --only-dependencies --flag QuickFuzz:net 29 | - stack build --only-dependencies --flag QuickFuzz:doc 30 | - stack build --only-dependencies --flag QuickFuzz:arch 31 | - stack build --only-dependencies --flag QuickFuzz:media 32 | - stack install alex # https://github.com/commercialhaskell/stack/issues/595 33 | - stack build --only-dependencies --flag QuickFuzz:code 34 | - stack install --flag QuickFuzz:all 35 | 36 | test: 37 | pre: 38 | - sudo apt-get install giflib-tools 39 | - stack install hlint 40 | override: 41 | - hlint --report src; exit 0 42 | - QuickFuzz gentest gif "/usr/bin/gifflip @@" -f zzuf -q 100 -l 1 -u 10 43 | - QuickFuzz gentest gif "/usr/bin/gifflip @@" -f radamsa -q 100 -l 1 -u 10 44 | - QuickFuzz gentest gif "/usr/bin/gifflip" -f zzuf -q 100 -l 1 -u 10 45 | - QuickFuzz gentest gif "/usr/bin/giflip" -f radamsa -q 100 -l 1 -u 10 46 | post: 47 | - mkdir -p $CIRCLE_ARTIFACTS/build/ 48 | - cp /home/ubuntu/.local/bin/QuickFuzz $CIRCLE_ARTIFACTS/build/QuickFuzz 49 | - bzip2 /home/ubuntu/.local/bin/QuickFuzz 50 | - cp /home/ubuntu/.local/bin/QuickFuzz.bz2 $CIRCLE_ARTIFACTS/build/QuickFuzz.bz2 51 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/Mutators.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickFuzz.Derive.Mutators where 2 | 3 | import Test.QuickCheck 4 | 5 | insertAt :: Int -> a -> [a] -> [a] 6 | insertAt idx y xs = as ++ (y:bs) 7 | where (as,bs) = splitAt idx xs 8 | 9 | expander :: (Arbitrary a) => [a] -> Gen [a] 10 | expander [] = do 11 | y <- arbitrary 12 | return $ [y] 13 | expander xs = do 14 | idx <- arbitrary :: Gen Int 15 | y <- arbitrary 16 | let idx' = mod (abs idx) (length xs) 17 | return $ insertAt idx' y xs 18 | 19 | deleteAt :: Int -> [a] -> [a] 20 | deleteAt _ [] = [] 21 | deleteAt idx xs = ys ++ (tail zs) 22 | where (ys,zs) = splitAt idx xs 23 | 24 | deleter :: [a] -> Gen [a] 25 | deleter [] = return [] 26 | deleter xs = do 27 | idx <- arbitrary :: Gen Int 28 | let idx' = mod (abs idx) (length xs) 29 | return $ deleteAt idx' xs 30 | 31 | 32 | -- taken from https://stackoverflow.com/questions/30551033/swap-two-elements-in-a-list-by-its-indices/30551130#30551130 33 | swapAt :: Int -> Int -> [a] -> [a] 34 | swapAt i j xs = let elemI = xs !! i 35 | elemJ = xs !! j 36 | left = take i xs 37 | middle = take (j - i - 1) (drop (i + 1) xs) 38 | right = drop (j + 1) xs 39 | in left ++ [elemJ] ++ middle ++ [elemI] ++ right 40 | 41 | swaper :: [a] -> Gen [a] 42 | swaper [] = return [] 43 | swaper [x] = return [x] 44 | swaper xs = do 45 | idx0 <- arbitrary :: Gen Int 46 | idx1 <- arbitrary :: Gen Int 47 | let idx0' = mod (abs idx0) (length xs) 48 | idx1' = mod (abs idx1) (length xs) 49 | return $ swapAt idx0' idx1' xs 50 | 51 | repeatAt :: Int -> Int -> [a] -> [a] 52 | repeatAt _ _ [] = [] 53 | repeatAt idx size xs = as ++ take size (repeat b) ++ (bs) 54 | where (as,b:bs) = splitAt idx xs 55 | 56 | magic = 42 57 | maxsize = 100 58 | 59 | repeater :: [a] -> Gen [a] 60 | repeater [] = return [] 61 | repeater xs = do 62 | size <- arbitrary :: Gen Int 63 | idx <- arbitrary :: Gen Int 64 | let size' = mod (magic*(abs size)) maxsize 65 | idx' = mod (abs idx) (length xs) 66 | return $ repeatAt idx' size' xs 67 | -------------------------------------------------------------------------------- /app/Utils/Mutation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Utils.Mutation where 3 | 4 | import Prelude hiding (null) 5 | import Data.Maybe 6 | import Data.ByteString.Lazy 7 | 8 | import Control.DeepSeq 9 | import Control.Monad 10 | 11 | import System.Random (randomIO) 12 | import Test.QuickCheck.Random (mkQCGen) 13 | import Test.QuickCheck.Gen 14 | 15 | import Test.QuickFuzz.Gen.FormatInfo 16 | 17 | import Args 18 | import Debug 19 | import Exception 20 | 21 | import System.Directory hiding (listDirectory, withCurrentDirectory) 22 | import Control.Exception ( bracket ) 23 | 24 | import Test.QuickCheck.Random (mkQCGen) 25 | import Test.QuickCheck.Gen 26 | import System.Random (randomIO) 27 | 28 | sampleGenerator gen n seed = 29 | let baseGen = resize n gen 30 | baseVal = unGen baseGen (mkQCGen seed) seed 31 | in baseVal 32 | 33 | -- Mutatue a reproductible value, retrying when the generated value fails to 34 | -- enconde 35 | strictMutate :: (Show base, NFData base) => QFCommand -> FormatInfo base actions 36 | -> [base] -> Int -> IO (ByteString, Int) 37 | strictMutate cmd fmt values n = do 38 | 39 | seed <- if usesSeed cmd 40 | then return (fromJust (genSeed cmd)) 41 | else abs <$> randomIO 42 | 43 | idx <- return $ (seed `mod` (Prelude.length values)) 44 | value <- return (values !! idx) 45 | --print value 46 | 47 | -- Mutate some value. 48 | mutated <- return $ sampleGenerator ((mutate fmt) value) n seed 49 | 50 | if ( show value == show mutated ) 51 | then strictMutate cmd fmt values n 52 | else ( do 53 | bsnf <- forceEvaluation (encode fmt mutated) 54 | case bsnf of 55 | Nothing -> do 56 | debug "Encoding failure" 57 | when (usesSeed cmd) 58 | (error "given seed raised an encoding error. Aborting") 59 | strictMutate cmd fmt values n 60 | Just (null -> True) -> do 61 | debug "Empty generation" 62 | when (usesSeed cmd) 63 | (error "given seed raised an encoding error. Aborting") 64 | strictMutate cmd fmt values n 65 | Just encoded -> do 66 | --debug (show val) 67 | return (encoded, seed) 68 | 69 | ) 70 | 71 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/FormatInfo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE IncoherentInstances #-} 3 | 4 | module Test.QuickFuzz.Gen.FormatInfo where 5 | 6 | import Data.Default 7 | import Data.Maybe 8 | 9 | import Data.ByteString.Lazy 10 | import Test.QuickCheck (Gen) 11 | 12 | data NoActions 13 | 14 | instance (Show NoActions) where 15 | show _ = "" 16 | 17 | 18 | -- | A data type describing the operations needed in order to manipulate 19 | -- supported file formats values 20 | data FormatInfo base actions = FormatInfo 21 | { decode :: ByteString -> base 22 | , encode :: base -> ByteString 23 | , random :: Gen base 24 | , value :: base -> String 25 | , mutate :: base -> Gen base 26 | , shrink :: base -> [base] 27 | , actions :: Maybe (ActionInfo base actions) 28 | , ext :: String 29 | } 30 | 31 | data ActionInfo base actions = ActionInfo 32 | { randomActions :: Gen actions 33 | , shrinkActions :: actions -> [actions] 34 | , performActions :: actions -> base 35 | , valueActions :: actions -> String 36 | } 37 | 38 | 39 | instance Default (FormatInfo base actions) where 40 | def = FormatInfo 41 | { decode = unsupported "decode" 42 | , encode = unsupported "encode" 43 | , random = unsupported "random" 44 | , value = unsupported "value" 45 | , mutate = unsupported "mutate" 46 | , shrink = unsupported "shrink" 47 | , actions = Nothing 48 | , ext = unsupported "ext" 49 | } 50 | 51 | instance Default (ActionInfo base actions) where 52 | def = ActionInfo 53 | { randomActions = unsupported "randomActions" 54 | , shrinkActions = unsupported "shrinkActions" 55 | , performActions = unsupported "performActions" 56 | , valueActions = unsupported "valueActions" 57 | } 58 | 59 | hasActions :: FormatInfo base actions -> Bool 60 | hasActions = isJust . actions 61 | 62 | getActionInfo :: FormatInfo base actions -> ActionInfo base actions 63 | getActionInfo fmt | hasActions fmt = fromJust (actions fmt) 64 | | otherwise = error "Trying to get ActionInfo for a unsupported format" 65 | 66 | unsupported op = error $ "internal operation '" ++ op ++ 67 | "' is not supported for this file format." 68 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Document/Css.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | module Test.QuickFuzz.Gen.Document.Css where 8 | 9 | import Data.Default 10 | 11 | import Test.QuickCheck 12 | 13 | import qualified Data.ByteString.Lazy as L 14 | import qualified Data.ByteString.Lazy.Char8 as L8 15 | import qualified Data.ByteString.Char8 as C8 16 | 17 | import Data.DeriveTH 18 | import Control.DeepSeq 19 | 20 | import Test.QuickFuzz.Derive.Actions 21 | import Test.QuickFuzz.Derive.Arbitrary 22 | import Test.QuickFuzz.Derive.Show 23 | import Test.QuickFuzz.Derive.NFData 24 | 25 | import Test.QuickFuzz.Gen.FormatInfo 26 | import Test.QuickFuzz.Gen.Base.ByteString 27 | import Test.QuickFuzz.Gen.Base.String 28 | 29 | import Text.PrettyPrint 30 | 31 | import Language.Css.Syntax 32 | import Language.Css.Pretty 33 | import Language.Css.Build 34 | import Language.Css.Build.Attributes 35 | import Language.Css.Build.Pseudos 36 | 37 | -- $(devActions ["Text.Blaze.Html5.Attributes"] ''Attribute False [] []) 38 | 39 | $(devActions["Language.Css.Build", "Language.Css.Build.Attributes", "Language.Css.Syntax" ] ''Attr False [''Attr] []) 40 | $(devArbitrary ''AttrAction) 41 | $(devArbitraryWithActions False ''Attr) 42 | 43 | -- $(devActions ["Language.Css.Build.Attributes", "Language.Css.Syntax"] ''AttrIdent False [''AttrIdent]) 44 | -- $(devArbitrary ''AttrIdentAction) 45 | -- $(devArbitraryWithActions False ''AttrIdent) 46 | 47 | $(devActions ["Language.Css.Build.Pseudos", "Language.Css.Syntax"] ''PseudoVal False [] []) 48 | $(devArbitrary ''PseudoValAction) 49 | $(devArbitraryWithActions False ''PseudoVal) 50 | 51 | 52 | $(devActions ["Language.Css.Build", "Language.Css.Syntax"] ''StyleBody False [] []) 53 | $(devArbitrary ''StyleBodyAction) 54 | $(devArbitraryWithActions False ''StyleBody) 55 | 56 | $(devActions ["Language.Css.Build", "Language.Css.Syntax"] ''StyleSheet False [] []) 57 | $(devArbitrary ''StyleSheetAction) 58 | $(devArbitraryWithActions False ''StyleSheet) 59 | 60 | $(devShow ''StyleSheetAction) 61 | 62 | instance NFData StyleSheet where 63 | rnf x = () 64 | 65 | cssInfo :: FormatInfo StyleSheet StyleSheetAction 66 | cssInfo = def 67 | { encode = L8.pack . render . pretty 68 | , random = arbitrary 69 | , actions = Just $ def 70 | { randomActions = arbitrary 71 | , shrinkActions = shrinkStyleSheetAction 72 | , performActions = performStyleSheetAction } 73 | , ext = "css" 74 | } 75 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Image/SVG.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE IncoherentInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Test.QuickFuzz.Gen.Image.SVG where 7 | 8 | import Data.Default 9 | 10 | import Graphics.Svg 11 | import Graphics.Svg.Types 12 | import Codec.Picture.Types 13 | 14 | import Text.XML.Light.Input( parseXMLDoc ) 15 | import Text.XML.Light.Output( ppcTopElement, prettyConfigPP ) 16 | 17 | import Test.QuickCheck 18 | import Control.Monad 19 | import Control.DeepSeq 20 | import Control.Monad.Trans 21 | import Control.Monad.Trans.State 22 | import Data.List 23 | import Data.Maybe 24 | import Data.Monoid 25 | 26 | import Test.QuickFuzz.Derive.Arbitrary 27 | 28 | import Test.QuickFuzz.Derive.Show 29 | import Test.QuickFuzz.Derive.NFData 30 | import Test.QuickFuzz.Derive.Mutation 31 | import Test.QuickFuzz.Gen.FormatInfo 32 | import Test.QuickFuzz.Gen.Base.ByteString 33 | import Test.QuickFuzz.Gen.Base.String 34 | 35 | import qualified Data.ByteString.Lazy.Char8 as L8 36 | import qualified Data.ByteString.Lazy as L 37 | 38 | import qualified Data.ByteString as BS 39 | 40 | 41 | --import Data.Text (unpack) 42 | --import Data.Text.Encoding (decodeUtf8) 43 | 44 | instance Arbitrary PixelRGBA8 where 45 | arbitrary = do 46 | (r,g,b,a) <- arbitrary 47 | return $ PixelRGBA8 r g b a 48 | 49 | devArbitrary ''Tree 50 | 51 | instance NFData PixelRGBA8 where 52 | rnf _ = () 53 | 54 | instance NFData Graphics.Svg.Types.Image where 55 | rnf _ = () 56 | 57 | devNFData ''Tree 58 | 59 | -- devShow '' 60 | 61 | mkDocument ts = Document { _viewBox= Just (0.0,0.0,128.0,128.0), 62 | _width = Just (Num 128.0), 63 | _height = Just (Num 128.0), 64 | _definitions= mempty, 65 | _elements = ts, 66 | _description = "", 67 | _styleRules = [], 68 | _documentLocation="." 69 | } 70 | 71 | getElements (Document { _elements = ts }) = ts 72 | 73 | --rdDocument bs = let fromJust (parseSvgFile "." bs) 74 | -- in f (Just x) = x 75 | 76 | svgInfo :: FormatInfo [Tree] NoActions 77 | svgInfo = def 78 | { encode = L8.pack . ppcTopElement prettyConfigPP . xmlOfDocument . mkDocument 79 | , decode = getElements . fromJust . (parseSvgFile ".") . BS.pack . L.unpack -- . L8.pack . L.unpack 80 | , random = arbitrary 81 | , mutate = mutt 82 | , value = show 83 | , ext = "svg" 84 | } 85 | -------------------------------------------------------------------------------- /app/Utils/Generation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Utils.Generation where 3 | 4 | import Prelude hiding (null) 5 | 6 | import Data.ByteString.Lazy 7 | --import qualified Data.ByteString as BS 8 | 9 | import Data.Maybe 10 | 11 | import Control.DeepSeq 12 | import Control.Monad 13 | 14 | import System.Random (randomIO) 15 | import Test.QuickCheck.Random (mkQCGen) 16 | import Test.QuickCheck.Gen 17 | 18 | import Test.QuickFuzz.Gen.FormatInfo 19 | 20 | import Args 21 | import Debug 22 | import Exception 23 | 24 | -- Generate a reproductible value, retrying when the generated value fails to 25 | -- enconde 26 | strictGenerate :: (Show base) => QFCommand -> FormatInfo base actions -> Int 27 | -> IO (Maybe actions, ByteString, Int) 28 | strictGenerate cmd fmt n = do 29 | 30 | -- Generate a seed or use a given one if supplied 31 | seed <- if usesSeed cmd 32 | then return (fromJust (genSeed cmd)) 33 | else abs <$> randomIO 34 | 35 | -- Generate a deterministic value using the previous seed 36 | let (mbacts, val) = if hasActions fmt 37 | then let actionsGen = resize n (randomActions (getActionInfo fmt)) 38 | actsVal = unGen actionsGen (mkQCGen seed) seed 39 | in (Just actsVal, performActions (getActionInfo fmt) actsVal) 40 | else let baseGen = resize n (random fmt) 41 | baseVal = unGen baseGen (mkQCGen seed) seed 42 | in (Nothing, baseVal) 43 | 44 | -- Try to evaluate the generated value, and retry if failed 45 | bsnf <- forceEvaluation (encode fmt val) 46 | case bsnf of 47 | Nothing -> do 48 | debug "Encoding failure" 49 | when (usesSeed cmd) 50 | (error "given seed raised an encoding error. Aborting") 51 | strictGenerate cmd fmt n 52 | Just (null -> True) -> do 53 | debug "Empty generation" 54 | when (usesSeed cmd) 55 | (error "given seed raised an encoding error. Aborting") 56 | strictGenerate cmd fmt n 57 | Just encoded -> do 58 | debug (show val) 59 | return (mbacts, encoded, seed) 60 | 61 | 62 | -- |Generation size distributions 63 | linear :: Int -> Int -> Int -> Int -> Int 64 | linear minY maxY dx n = minY + floor (slope * fromIntegral ((n-1) `mod` dx)) 65 | where slope = fromIntegral (maxY - minY + 1) / fromIntegral dx 66 | 67 | linearSize :: QFCommand -> Int -> Int 68 | linearSize cmd = linear (minSize cmd) (maxSize cmd) (genQty cmd) 69 | 70 | sawSize :: QFCommand -> Int -> Int 71 | sawSize cmd = linear (minSize cmd) (maxSize cmd) (maxSize cmd - minSize cmd + 1) 72 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/Image.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, DeriveGeneric #-} 2 | 3 | module Test.QuickFuzz.Gen.Base.Image where 4 | 5 | import Control.DeepSeq 6 | 7 | import Codec.Picture.Types 8 | import Codec.Picture.Metadata 9 | import Codec.Picture.ColorQuant 10 | import Test.QuickCheck 11 | 12 | import Data.Word(Word8, Word16, Word32) 13 | import qualified Data.Vector.Storable as VS 14 | 15 | import Test.QuickFuzz.Derive.Actions 16 | import Test.QuickFuzz.Derive.Arbitrary 17 | 18 | instance Arbitrary PixelRGBA8 where 19 | arbitrary = do 20 | (r,g,b,a) <- arbitrary 21 | return $ PixelRGBA8 r g b a 22 | 23 | instance Show (Image PixelRGBA8) where 24 | show x = "Image RGBA8(" ++ show (imageWidth x) ++ ", " ++ show (imageHeight x) ++ ")" 25 | 26 | 27 | instance Arbitrary (Image Pixel8) where 28 | arbitrary = do 29 | l <- infiniteListOf (arbitrary :: Gen Pixel8) 30 | Positive w <- (arbitrary :: Gen (Positive Int)) 31 | Positive h <- (arbitrary :: Gen (Positive Int)) 32 | return $ Image { imageWidth = w, imageHeight = h, imageData = VS.fromList (take (3*w*h) l) } 33 | 34 | instance Show (Image Pixel8) where 35 | show x = "Image Pixel8(" ++ show (imageWidth x) ++ ", " ++ show (imageHeight x) ++ ")" 36 | 37 | instance Arbitrary (Image PixelRGB8) where 38 | arbitrary = do 39 | l <- infiniteListOf (arbitrary :: Gen Word8) 40 | Positive w <- (arbitrary :: Gen (Positive Int)) 41 | Positive h <- (arbitrary :: Gen (Positive Int)) 42 | return $ Image { imageWidth = w, imageHeight = h, imageData = VS.fromList (take (w*h) l) } 43 | 44 | instance Show (Image PixelRGB8) where 45 | show x = "RGB8 Image(" ++ show (imageWidth x) ++ ", " ++ show (imageHeight x) ++ ")" 46 | 47 | instance Arbitrary (Image PixelRGB16) where 48 | arbitrary = do 49 | l <- infiniteListOf (arbitrary :: Gen Word16) 50 | Positive w <- (arbitrary :: Gen (Positive Int)) 51 | Positive h <- (arbitrary :: Gen (Positive Int)) 52 | return $ Image { imageWidth = w, imageHeight = h, imageData = VS.fromList (take (w*h) l) } 53 | 54 | instance Show (Image PixelRGB16) where 55 | show x = "RGB16 Image(" ++ show (imageWidth x) ++ ", " ++ show (imageHeight x) ++ ")" 56 | 57 | instance Arbitrary (Elem Keys) where 58 | arbitrary = do 59 | k <- (arbitrary :: Gen (Keys Word)) 60 | w <- (arbitrary :: Gen (Word)) 61 | return (k :=> w) 62 | 63 | instance Arbitrary (Keys Word) where 64 | arbitrary = do 65 | word <- (arbitrary :: Gen Word) 66 | oneof [return DpiX, return DpiY, return Width, return Height] 67 | 68 | $(devActions ["Codec.Picture.Metadata"] ''Metadatas False [''Word] ['getMetadatas]) 69 | $(devArbitrary ''MetadatasAction) 70 | $(devArbitraryWithActions False ''Metadatas) 71 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Bnfc/PrintGrammar.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 2 | module Test.QuickFuzz.Gen.Bnfc.PrintGrammar where 3 | 4 | -- pretty-printer generated by the BNF converter 5 | 6 | import Test.QuickFuzz.Gen.Bnfc.AbsGrammar 7 | import Data.Char 8 | 9 | 10 | -- the top-level printing method 11 | printTree :: Print a => a -> String 12 | printTree = render . prt 0 13 | 14 | type Doc = [ShowS] -> [ShowS] 15 | 16 | doc :: ShowS -> Doc 17 | doc = (:) 18 | 19 | render :: Doc -> String 20 | render d = rend 0 (map ($ "") $ d []) "" where 21 | rend i ss = case ss of 22 | "[" :ts -> showChar '[' . rend i ts 23 | "(" :ts -> showChar '(' . rend i ts 24 | "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts 25 | "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts 26 | "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts 27 | ";" :ts -> showChar ';' . new i . rend i ts 28 | t : "," :ts -> showString t . space "," . rend i ts 29 | t : ")" :ts -> showString t . showChar ')' . rend i ts 30 | t : "]" :ts -> showString t . showChar ']' . rend i ts 31 | t :ts -> space t . rend i ts 32 | _ -> id 33 | new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace 34 | space t = showString t . (\s -> if null s then "" else (' ':s)) 35 | 36 | parenth :: Doc -> Doc 37 | parenth ss = doc (showChar '(') . ss . doc (showChar ')') 38 | 39 | concatS :: [ShowS] -> ShowS 40 | concatS = foldr (.) id 41 | 42 | concatD :: [Doc] -> Doc 43 | concatD = foldr (.) id 44 | 45 | replicateS :: Int -> ShowS -> ShowS 46 | replicateS n f = concatS (replicate n f) 47 | 48 | -- the printer class does the job 49 | class Print a where 50 | prt :: Int -> a -> Doc 51 | prtList :: Int -> [a] -> Doc 52 | prtList i = concatD . map (prt i) 53 | 54 | instance Print a => Print [a] where 55 | prt = prtList 56 | 57 | instance Print Char where 58 | prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') 59 | prtList _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') 60 | 61 | mkEsc :: Char -> Char -> ShowS 62 | mkEsc q s = case s of 63 | _ | s == q -> showChar '\\' . showChar s 64 | '\\'-> showString "\\\\" 65 | '\n' -> showString "\\n" 66 | '\t' -> showString "\\t" 67 | _ -> showChar s 68 | 69 | prPrec :: Int -> Int -> Doc -> Doc 70 | prPrec i j = if j prPrec i 0 (concatD [prt 0 exp1, doc (showString "+"), prt 1 exp2]) 86 | ESub exp1 exp2 -> prPrec i 0 (concatD [prt 0 exp1, doc (showString "-"), prt 1 exp2]) 87 | EMul exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "*"), prt 2 exp2]) 88 | EDiv exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "/"), prt 2 exp2]) 89 | EInt n -> prPrec i 2 (concatD [prt 0 n]) 90 | 91 | 92 | -------------------------------------------------------------------------------- /app/Utils/Decoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module Utils.Decoding where 5 | 6 | import Data.Maybe 7 | import Data.ByteString.Lazy 8 | 9 | import Control.DeepSeq 10 | import Control.Monad 11 | 12 | import System.Random (randomIO) 13 | import Test.QuickCheck.Random (mkQCGen) 14 | import Test.QuickCheck.Gen 15 | 16 | import Test.QuickFuzz.Gen.FormatInfo 17 | 18 | import Args 19 | import Debug 20 | import Exception 21 | import Utils.Generation 22 | 23 | import System.Directory hiding (listDirectory, withCurrentDirectory) 24 | import Control.Exception ( bracket ) 25 | 26 | listDirectory :: FilePath -> IO [FilePath] 27 | listDirectory path = 28 | (Prelude.filter f) <$> (getDirectoryContents path) 29 | where f filename = filename /= "." && filename /= ".." 30 | 31 | withCurrentDirectory :: FilePath -- ^ Directory to execute in 32 | -> IO a -- ^ Action to be executed 33 | -> IO a 34 | withCurrentDirectory dir action = 35 | bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do 36 | setCurrentDirectory dir 37 | action 38 | 39 | decodeFile decf file = do 40 | !buf <- Data.ByteString.Lazy.readFile file 41 | forceEvaluation (decf buf) 42 | 43 | -- Decode the files inside a directory 44 | strictDecodeDir :: (Show base, NFData base) => QFCommand -> FormatInfo base actions 45 | -> IO [base] 46 | strictDecodeDir cmd fmt = do 47 | fs <- listDirectory (inDir cmd) 48 | xs <- mapM makeRelativeToCurrentDirectory fs 49 | bsnfs <- withCurrentDirectory (inDir cmd) (mapM (decodeFile (decode fmt)) xs) 50 | 51 | --xs <- withCurrentDirectory (inDir cmd) (mapM (Data.ByteString.Lazy.readFile) xs) 52 | --bsnfs <- mapM (\x -> forceEvaluation ((decode fmt) x)) xs 53 | bsnfs <- return $ Prelude.filter isJust bsnfs 54 | bsnfs <- return $ Prelude.map fromJust bsnfs 55 | Prelude.putStrLn $ "Loaded " ++ (show (Prelude.length bsnfs)) ++ " of " ++ (show (Prelude.length fs)) ++ " files to mutate." 56 | return bsnfs 57 | 58 | 59 | -- Decode a single file 60 | strictDecodeFile :: (Show base, NFData base) => QFCommand -> FormatInfo base actions 61 | -> IO [base] 62 | strictDecodeFile cmd fmt = do 63 | let filename = inDir cmd 64 | xs <- return [filename] 65 | bsnfs <- mapM (decodeFile (decode fmt)) xs 66 | bsnfs <- return $ Prelude.filter isJust bsnfs 67 | bsnfs <- return $ Prelude.map fromJust bsnfs 68 | --Prelude.putStrLn $ "Loaded " ++ (show (Prelude.length bsnfs)) ++ " of " ++ (show (Prelude.length fs)) ++ " files to mutate." 69 | return bsnfs 70 | 71 | 72 | quickGen cmd fmt = let baseGen = resize (maxSize cmd) (random fmt) 73 | baseVal = unGen baseGen (mkQCGen 0) 0 74 | in return [baseVal] 75 | 76 | strictDecode :: (Show base, NFData base) => QFCommand -> FormatInfo base actions 77 | -> IO [base] 78 | strictDecode cmd fmt = do 79 | b <- System.Directory.doesFileExist (inDir cmd) 80 | ys <- (if b then strictDecodeFile cmd fmt 81 | else strictDecodeDir cmd fmt) 82 | if Prelude.null ys then (quickGen cmd fmt) --(error $ "Impossible to load " ++ (inDir cmd)) 83 | else return ys 84 | 85 | 86 | -------------------------------------------------------------------------------- /app/Run/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Run.Test (runTest) where 3 | 4 | import Prelude hiding (writeFile, length) 5 | 6 | import Data.ByteString.Lazy hiding (putStrLn) 7 | import Data.List hiding (length) 8 | import Data.Maybe 9 | 10 | import Control.Monad 11 | import System.Directory 12 | 13 | import Test.QuickFuzz.Gen.FormatInfo 14 | 15 | import Args 16 | import Debug 17 | import Exception 18 | import Process 19 | import Utils 20 | 21 | 22 | -- |Return a lazy list of steps to execute 23 | getSteps :: QFCommand -> [Int] 24 | getSteps (maxTries -> Nothing) = [1..] 25 | getSteps (maxTries -> Just n) = [1..n] 26 | 27 | 28 | -- Run test subcommand 29 | runTest :: (Show actions, Show base) => 30 | QFCommand -> FormatInfo base actions -> IO () 31 | runTest cmd fmt = do 32 | debug (show cmd) 33 | when (hasActions fmt) 34 | (putStrLn "Selected format supports actions based generation/shrinking!") 35 | 36 | createDirectoryIfMissing True (outDir cmd) 37 | 38 | mkName <- nameMaker cmd fmt 39 | (shcmd, testname) <- prepareCli cmd fmt 40 | 41 | let cleanup = when (usesFile cmd) $ removeFile testname 42 | 43 | -- Generation-execution-report loop 44 | forM_ (getSteps cmd) $ \n -> handleSigInt cleanup $ do 45 | 46 | let size = sawSize cmd n 47 | 48 | -- Generate a value and encode it in a bytestring. 49 | -- This fully evaluates the generated value, and retry 50 | -- the generation if the value cant be encoded. 51 | (mbacts, encoded, seed) <- strictGenerate cmd fmt size 52 | 53 | -- Fuzz the generated value if required. 54 | fuzzed <- if usesFuzzer cmd 55 | then fuzz (fromJust (fuzzer cmd)) encoded seed 56 | else return encoded 57 | 58 | -- Execute the command using either a file or stdin. 59 | exitcode <- if usesFile cmd 60 | then writeFile testname fuzzed >> execute (verbose cmd) shcmd 61 | else executeFromStdin (verbose cmd) shcmd fuzzed 62 | 63 | -- Report and move failed test cases. 64 | when (hasFailed exitcode) $ do 65 | let failname = mkName n seed size 66 | mapM_ putStrLn [ "Test case number " ++ show n ++ " has failed. " 67 | , "Moving to " ++ failname ] 68 | if usesFile cmd 69 | then renameFile testname failname 70 | else writeFile failname fuzzed 71 | 72 | -- Shrink if necessary 73 | when (hasFailed exitcode && shrinking cmd) $ do 74 | 75 | -- Execute a shrinking stategy acordingly to the -a/--actions flag 76 | (smallest, nshrinks, nfails) <- if hasActions fmt 77 | then runShrinkActions cmd fmt shcmd testname 78 | (fromJust mbacts) (diff encoded fuzzed) 79 | else runShrinkByteString cmd shcmd testname fuzzed 80 | 81 | printShrinkingFinished 82 | 83 | -- Report the shrinking results 84 | let shrinkName = mkName n seed size ++ ".reduced" 85 | mapM_ putStrLn 86 | [ "Reduced from " ++ show (length fuzzed) ++ " bytes" 87 | ++ " to " ++ show (length smallest) ++ " bytes" 88 | , "After executing " ++ show nshrinks ++ " shrinks with " 89 | ++ show nfails ++ " failing shrinks. " 90 | , "Saving to " ++ shrinkName ] 91 | writeFile shrinkName smallest 92 | 93 | when (not $ verbose cmd) (printTestStep n) 94 | 95 | -- Clean up the mess 96 | cleanup 97 | printFinished 98 | 99 | 100 | -------------------------------------------------------------------------------- /app/Run/GenTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Run.GenTest (runGenTest) where 3 | 4 | import Prelude hiding (writeFile, length) 5 | 6 | import Data.ByteString.Lazy hiding (putStrLn) 7 | import Data.List hiding (length) 8 | import Data.Maybe 9 | 10 | import Control.Monad 11 | import System.Directory 12 | 13 | import Test.QuickFuzz.Gen.FormatInfo 14 | 15 | import Args 16 | import Debug 17 | import Exception 18 | import Process 19 | import Utils 20 | 21 | 22 | -- |Return a lazy list of steps to execute 23 | getSteps :: QFCommand -> [Int] 24 | getSteps (maxTries -> Nothing) = [1..] 25 | getSteps (maxTries -> Just n) = [1..n] 26 | 27 | 28 | -- Run test subcommand 29 | runGenTest :: (Show actions, Show base) => 30 | QFCommand -> FormatInfo base actions -> IO () 31 | runGenTest cmd fmt = do 32 | debug (show cmd) 33 | when (hasActions fmt) 34 | (putStrLn "Selected format supports actions based generation/shrinking!") 35 | 36 | createDirectoryIfMissing True (outDir cmd) 37 | 38 | mkName <- nameMaker cmd fmt 39 | (shcmd, testname) <- prepareCli cmd fmt 40 | 41 | let cleanup = when (usesFile cmd) $ removeFile testname 42 | 43 | -- Generation-execution-report loop 44 | forM_ (getSteps cmd) $ \n -> handleSigInt cleanup $ do 45 | 46 | let size = sawSize cmd n 47 | 48 | -- Generate a value and encode it in a bytestring. 49 | -- This fully evaluates the generated value, and retry 50 | -- the generation if the value cant be encoded. 51 | (mbacts, encoded, seed) <- strictGenerate cmd fmt size 52 | 53 | -- Fuzz the generated value if required. 54 | fuzzed <- if usesFuzzer cmd 55 | then fuzz (fromJust (fuzzer cmd)) encoded seed 56 | else return encoded 57 | 58 | -- Execute the command using either a file or stdin. 59 | exitcode <- if usesFile cmd 60 | then writeFile testname fuzzed >> execute (verbose cmd) shcmd 61 | else executeFromStdin (verbose cmd) shcmd fuzzed 62 | 63 | -- Report and move failed test cases. 64 | when (hasFailed exitcode) $ do 65 | let failname = mkName n seed size 66 | mapM_ putStrLn [ "Test case number " ++ show n ++ " has failed. " 67 | , "Moving to " ++ failname ] 68 | if usesFile cmd 69 | then renameFile testname failname 70 | else writeFile failname fuzzed 71 | 72 | -- Shrink if necessary 73 | when (hasFailed exitcode && shrinking cmd) $ do 74 | 75 | -- Execute a shrinking stategy acordingly to the -a/--actions flag 76 | (smallest, nshrinks, nfails) <- if hasActions fmt 77 | then runShrinkActions cmd fmt shcmd testname 78 | (fromJust mbacts) (diff encoded fuzzed) 79 | else runShrinkByteString cmd shcmd testname fuzzed 80 | 81 | printShrinkingFinished 82 | 83 | -- Report the shrinking results 84 | let shrinkName = mkName n seed size ++ ".reduced" 85 | mapM_ putStrLn 86 | [ "Reduced from " ++ show (length fuzzed) ++ " bytes" 87 | ++ " to " ++ show (length smallest) ++ " bytes" 88 | , "After executing " ++ show nshrinks ++ " shrinks with " 89 | ++ show nfails ++ " failing shrinks. " 90 | , "Saving to " ++ shrinkName ] 91 | writeFile shrinkName smallest 92 | 93 | when (not $ verbose cmd) (printTestStep n) 94 | 95 | -- Clean up the mess 96 | cleanup 97 | printFinished 98 | 99 | 100 | -------------------------------------------------------------------------------- /app/Run/MutTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Run.MutTest (runMutTest) where 3 | 4 | import Prelude hiding (writeFile) 5 | 6 | import Data.ByteString.Lazy hiding (putStrLn) 7 | import Data.List hiding (length) 8 | import Data.Maybe 9 | import GHC.Int 10 | 11 | import Control.Monad 12 | import Control.DeepSeq 13 | import System.Directory 14 | 15 | import Test.QuickFuzz.Gen.FormatInfo 16 | 17 | import Args 18 | import Debug 19 | import Exception 20 | import Process 21 | import Utils 22 | 23 | import Utils.Decoding 24 | import Utils.Mutation 25 | 26 | import Test.QuickCheck.Random (mkQCGen) 27 | import Test.QuickCheck.Gen 28 | import System.Random (randomIO) 29 | 30 | -- |Return a lazy list of steps to execute 31 | getSteps :: QFCommand -> [Int] 32 | getSteps (maxTries -> Nothing) = [1..] 33 | getSteps (maxTries -> Just n) = [1..n] 34 | 35 | -- Run test subcommand 36 | runMutTest :: (Show actions, Show base, NFData base) => 37 | QFCommand -> FormatInfo base actions -> IO () 38 | runMutTest cmd fmt = do 39 | debug (show cmd) 40 | when (hasActions fmt) 41 | (putStrLn "Selected format supports actions based generation/shrinking!") 42 | 43 | createDirectoryIfMissing True (outDir cmd) 44 | values <- strictDecode cmd fmt 45 | 46 | mkName <- nameMaker cmd fmt 47 | (shcmd, testname) <- prepareCli cmd fmt 48 | 49 | let cleanup = when (usesFile cmd) $ removeFile testname 50 | 51 | -- Generation-execution-report loop 52 | forM_ (getSteps cmd) $ \n -> handleSigInt cleanup $ do 53 | 54 | let size = sawSize cmd n 55 | 56 | -- Generate a value and encode it in a bytestring. 57 | -- This fully evaluates the generated value, and retry 58 | -- the generation if the value cant be encoded. 59 | 60 | -- Mutate some value. 61 | (mutated, seed) <- strictMutate cmd fmt values size 62 | 63 | -- Execute the command using either a file or stdin. 64 | exitcode <- if usesFile cmd 65 | then writeFile testname mutated >> execute (verbose cmd) shcmd 66 | else executeFromStdin (verbose cmd) shcmd mutated 67 | 68 | -- Report and move failed test cases. 69 | when (hasFailed exitcode) $ do 70 | let failname = mkName n seed size 71 | mapM_ putStrLn [ "Test case number " ++ show n ++ " has failed. " 72 | , "Moving to " ++ failname ] 73 | if usesFile cmd 74 | then renameFile testname failname 75 | else writeFile failname mutated 76 | 77 | -- Shrink if necessary 78 | {- 79 | when (hasFailed exitcode && shrinking cmd) $ do 80 | 81 | -- Execute a shrinking stategy acordingly to the -a/--actions flag 82 | (smallest, nshrinks, nfails) <- if hasActions fmt 83 | then runShrinkActions cmd fmt shcmd testname 84 | (fromJust mbacts) (diff encoded mutated) 85 | else runShrinkByteString cmd shcmd testname mutated 86 | 87 | printShrinkingFinished 88 | 89 | -- Report the shrinking results 90 | let shrinkName = mkName n seed size ++ ".reduced" 91 | mapM_ putStrLn 92 | [ "Reduced from " ++ show (length mutated) ++ " bytes" 93 | ++ " to " ++ show (length smallest) ++ " bytes" 94 | , "After executing " ++ show nshrinks ++ " shrinks with " 95 | ++ show nfails ++ " failing shrinks. " 96 | , "Saving to " ++ shrinkName ] 97 | writeFile shrinkName smallest 98 | -} 99 | when (not $ verbose cmd) (printTestStep n) 100 | 101 | -- Clean up the mess 102 | cleanup 103 | when (not $ verbose cmd) printFinished 104 | -------------------------------------------------------------------------------- /app/Utils/Shrink.hs: -------------------------------------------------------------------------------- 1 | module Utils.Shrink where 2 | 3 | import Prelude hiding (init, inits, tail, tails, writeFile, length) 4 | 5 | import Data.ByteString.Lazy hiding (putStrLn, zip) 6 | import Control.Concurrent.MVar 7 | import Control.Monad 8 | 9 | import Test.QuickCheck hiding (verbose) 10 | 11 | import Test.QuickCheck.Monadic 12 | import Test.QuickFuzz.Gen.FormatInfo 13 | 14 | import Args hiding (shrinking) 15 | import Process 16 | 17 | import Utils.Patch 18 | import Utils.Console 19 | 20 | -- |ByteString generic shrinking 21 | shrinkBS :: ByteString -> [ByteString] 22 | shrinkBS bs = 23 | [ append h t | (h, t) <- zip (inits (init bs)) (tails (tail bs)) ] 24 | 25 | 26 | runShrinkActions :: (Show actions) => QFCommand -> FormatInfo base actions 27 | -> ShellCommand -> FilePath -> actions -> [Patch] 28 | -> IO (ByteString, Int, Int) 29 | runShrinkActions cmd fmt shcmd testname acts delta = do 30 | putStrLn "Shrinking over actions has begun..." 31 | putStrLn "Action to reduce:" 32 | print acts 33 | 34 | let shrinkActs = shrinkActions (getActionInfo fmt) 35 | encodeActs = encode fmt . performActions (getActionInfo fmt) 36 | 37 | runShrink acts = runShrink' acts (shrinkActs acts) 0 0 38 | 39 | runShrink' last [] nshrinks nfails = return (last, nshrinks, nfails) 40 | runShrink' last (x:xs) nshrinks nfails = do 41 | 42 | let enc = encodeActs x 43 | encoded = if usesFuzzer cmd 44 | then patch delta enc 45 | else enc 46 | print x 47 | printShrinkStep (length encoded) 48 | 49 | exitcode <- if usesFile cmd 50 | then writeFile testname encoded >> execute (verbose cmd) shcmd 51 | else executeFromStdin (verbose cmd) shcmd encoded 52 | 53 | if hasFailed exitcode 54 | then runShrink' x (shrinkActs x) (nshrinks+1) (nfails+1) 55 | else runShrink' last xs (nshrinks+1) nfails 56 | 57 | (smallestActs, nshrinks, nfails) <- runShrink acts 58 | 59 | let encoded = if usesFuzzer cmd 60 | then patch delta (encodeActs smallestActs) 61 | else encodeActs smallestActs 62 | 63 | return (encoded, nshrinks, nfails) 64 | 65 | 66 | runShrinkByteString :: QFCommand -> ShellCommand -> FilePath 67 | -> ByteString -> IO (ByteString, Int, Int) 68 | runShrinkByteString cmd shcmd testname fuzzed = do 69 | putStrLn "Shrinking over bytes has begun..." 70 | 71 | let qcArgs = stdArgs {chatty = False} 72 | shrinkingProp = shrinking shrinkBS fuzzed 73 | 74 | -- Create an MVar to take the smallest shrink from inside of the QuickCheck 75 | -- loop, and also count the number of shinks and intermediate fails. 76 | shrinkStatus <- newMVar (fuzzed, 0, 0) 77 | 78 | -- Run QuickCheck using a shrinking property 79 | quickCheckWith qcArgs $ shrinkingProp $ \shrink -> 80 | monadicIO $ do 81 | run $ printShrinkStep (length shrink) 82 | 83 | -- Execute the shrink 84 | exitcode <- run $ if usesFile cmd 85 | then writeFile testname shrink >> execute (verbose cmd) shcmd 86 | else executeFromStdin (verbose cmd) shcmd shrink 87 | 88 | -- When a shrink fails, update the MVar with the value. 89 | if hasFailed exitcode 90 | then run $ modifyMVar_ shrinkStatus 91 | (\(_, shn, shf) -> return (shrink, shn + 1, shf + 1)) 92 | else run $ modifyMVar_ shrinkStatus 93 | (\(sh, shn, shf) -> return (sh, shn + 1, shf)) 94 | 95 | -- Tell QuickCheck if the case has failed 96 | assert $ not $ hasFailed exitcode 97 | 98 | (smallest, nshrinks, nfails) <- takeMVar shrinkStatus 99 | return (smallest, nshrinks, nfails) 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # QuickFuzz 2 | 3 | QuickFuzz, a tool written in Haskell designed for testing un- 4 | expected inputs of common file formats on third-party software, 5 | taking advantage of off-the-shelf, well known fuzzers. 6 | Unlike other generational fuzzers, QuickFuzz does not require 7 | to write specifications for the file formats in question since it relies 8 | on existing file-format-handling libraries available on the Haskell 9 | code repository. There is more information in its [website](http://quickfuzz.cifasis-conicet.gov.ar/). 10 | 11 | [![CircleCI](https://circleci.com/gh/CIFASIS/QuickFuzz.svg?style=svg)](https://circleci.com/gh/CIFASIS/QuickFuzz) 12 | 13 | 14 | ## Example 15 | 16 | In this example, we uncover a null pointer dereference in gif2webp from [libwebp 0.5](https://github.com/webmproject/libwebp/releases/tag/v0.5.0): 17 | 18 | ``` 19 | $ QuickFuzz gentest gif "./gif2webp @@ -o /dev/null" -l 1 -u 10 -f radamsa 20 | ... 21 | Test case number 4481 has failed. 22 | Moving to outdir/QuickFuzz.68419739009.4481.3692945303624111961.1.gif 23 | ... 24 | ``` 25 | 26 | We found a crash. We can inspect it manually to verify it is a null pointer issue: 27 | 28 | ``` 29 | $ ./gif2webp outdir/QuickFuzz.68419739009.4481.3692945303624111961.1.gif 30 | ==10953== ERROR: AddressSanitizer: SEGV on unknown address 0x000000000000 31 | (pc 0x000000403ff9 sp 0x7fffffffd6e0 bp 0x7fffffffded0 T0) 32 | AddressSanitizer can not provide additional info. 33 | #0 0x403ff8 (examples/gif2webp+0x403ff8) 34 | #1 0x7ffff437af44 (/lib/x86_64-linux-gnu/libc-2.19.so+0x21f44) 35 | #2 0x401b18 (examples/gif2webp+0x401b18) 36 | ==10953== ABORTING 37 | ``` 38 | 39 | Finally, we can shrink the crashing input to obtain a smaller file: 40 | 41 | ``` 42 | $ QuickFuzz gentest gif "./gif2webp @@ -o /dev/null" -l 1 -s 3692945303624111961 -f radamsa -r 43 | Test case number 1 has failed. 44 | Moving to outdir/QuickFuzz.68997856397.1.3692945303624111961.1.gif 45 | Shrinking over bytes has begun... 46 | Testing shrink of size 48 47 | Testing shrink of size 47 48 | ... 49 | Testing shrink of size 15 50 | Shrinking finished 51 | Reduced from 48 bytes to 16 bytes 52 | After executing 554 shrinks with 33 failing shrinks. 53 | Saving to outdir/QuickFuzz.68997856397.1.3692945303624111961.1.gif.reduced 54 | Finished! 55 | ``` 56 | 57 | ## Installation 58 | 59 | We **support** [Stack](www.haskellstack.org) to compile and install QuickFuzz. Before starting with it, make sure you have libgmp-dev installed otherwise ghc will fail to compile. Also, zlib.h is required to compile QuickFuzz (some packages require it). For instance, in Ubuntu/Debian: 60 | 61 | # apt-get install zlib1g-dev libgmp-dev libtinfo-dev 62 | 63 | After [installing stack](http://docs.haskellstack.org/en/stable/README/#how-to-install), you should: 64 | 65 | $ git clone https://github.com/CIFASIS/QuickFuzz --depth 1 66 | $ cd QuickFuzz 67 | $ install_fuzzers.sh 68 | $ stack setup 69 | 70 | Because *QuickFuzz* generates a lot of dependencies that may not be necessary to test an specific category of files, we modularized the project with different activation flags. Currently we have 7 flags: 71 | 72 | | Flag | Supported formats | 73 | |-------:|:-----------------------------| 74 | | image | svg, png, gif, tiff, jpeg | 75 | | arch | tar, zip | 76 | | doc | html, css, pdf, ps, eps, xml | 77 | | code | c, js, py, go, lua, evm | 78 | | media | wav | 79 | | net | http | 80 | | pki | asn1, crl, x509 | 81 | | bnfc | cf, grammer format | 82 | 83 | For instance, to compile only with image generation (Bmp, Gif, Png, Ico, ..): 84 | 85 | $ stack install --flag QuickFuzz:image 86 | 87 | Because of a Stack issue, you must install `alex` and `happy` manually before enabling the `code` flag: 88 | 89 | $ stack install alex happy 90 | 91 | ### Cabal Installation 92 | 93 | Direct cabal installation is **not** recommended nor supported. 94 | 95 | ## Authors 96 | 97 | * Pablo **Buiras** ([Chalmers University of Technology](http://www.chalmers.se/en/Pages/default.aspx)) 98 | * Martín **Ceresa** ([CIFASIS-Conicet](http://cifasis-conicet.gov.ar/)) 99 | * Gustavo **Grieco** ([CIFASIS-Conicet](http://cifasis-conicet.gov.ar/) and [VERIMAG](http://www-verimag.imag.fr/?lang=en)) 100 | * Agustín **Mista** ([Universidad Nacional de Rosario](http://www.unr.edu.ar/)) 101 | 102 | ### Students 103 | 104 | * Franco **Costantini** 105 | * Lucas **Salvatore** 106 | 107 | ### Former Members 108 | 109 | * Martín **Escarrá** ([Universidad Nacional de Rosario](http://www.unr.edu.ar/)) 110 | 111 | ## Mailing list 112 | 113 | You can join the [QuickFuzz mailing group](https://groups.google.com/forum/#!forum/QuickFuzz-users) to get notifications of new features and releases. To join, you can send an empty email to QuickFuzz-users+subscribe@googlegroups.com. 114 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, FlexibleInstances, IncoherentInstances#-} 2 | 3 | module Test.QuickFuzz.Gen.Base.Time where 4 | 5 | -- Code from quickcheck-instances package 6 | 7 | import Test.QuickCheck 8 | import Test.QuickCheck.Function 9 | 10 | import qualified Data.Time as Time 11 | import qualified Data.Time.Clock.TAI as Time 12 | 13 | instance Arbitrary Time.Day where 14 | arbitrary = Time.ModifiedJulianDay <$> (2000 +) <$> arbitrary 15 | shrink = (Time.ModifiedJulianDay <$>) . shrink . Time.toModifiedJulianDay 16 | 17 | instance CoArbitrary Time.Day where 18 | coarbitrary = coarbitrary . Time.toModifiedJulianDay 19 | 20 | instance Function Time.Day where 21 | function = functionMap Time.toModifiedJulianDay Time.ModifiedJulianDay 22 | 23 | instance Arbitrary Time.UniversalTime where 24 | arbitrary = Time.ModJulianDate <$> (2000 +) <$> arbitrary 25 | shrink = (Time.ModJulianDate <$>) . shrink . Time.getModJulianDate 26 | 27 | instance CoArbitrary Time.UniversalTime where 28 | coarbitrary = coarbitrary . Time.getModJulianDate 29 | 30 | instance Arbitrary Time.DiffTime where 31 | arbitrary = arbitrarySizedFractional 32 | 33 | -- #if MIN_VERSION_time(1,3,0) 34 | -- shrink = shrinkRealFrac 35 | -- #else 36 | -- shrink = (fromRational <$>) . shrink . toRational 37 | -- #endif 38 | 39 | instance CoArbitrary Time.DiffTime where 40 | coarbitrary = coarbitraryReal 41 | 42 | instance Function Time.DiffTime where 43 | function = functionMap toRational fromRational 44 | 45 | instance Arbitrary Time.UTCTime where 46 | arbitrary = 47 | Time.UTCTime 48 | <$> arbitrary 49 | <*> (fromRational . toRational <$> choose (0::Double, 86400)) 50 | shrink ut@(Time.UTCTime day dayTime) = 51 | [ ut { Time.utctDay = d' } | d' <- shrink day ] ++ 52 | [ ut { Time.utctDayTime = t' } | t' <- shrink dayTime ] 53 | 54 | instance CoArbitrary Time.UTCTime where 55 | coarbitrary (Time.UTCTime day dayTime) = 56 | coarbitrary day . coarbitrary dayTime 57 | 58 | instance Function Time.UTCTime where 59 | function = functionMap (\(Time.UTCTime day dt) -> (day,dt)) 60 | (uncurry Time.UTCTime) 61 | 62 | instance Arbitrary Time.NominalDiffTime where 63 | arbitrary = arbitrarySizedFractional 64 | shrink = shrinkRealFrac 65 | 66 | instance CoArbitrary Time.NominalDiffTime where 67 | coarbitrary = coarbitraryReal 68 | 69 | instance Arbitrary Time.TimeZone where 70 | arbitrary = 71 | Time.TimeZone 72 | <$> choose (-12*60,14*60) -- utc offset (m) 73 | <*> arbitrary -- is summer time 74 | <*> (sequence . replicate 4 $ choose ('A','Z')) 75 | shrink tz@(Time.TimeZone minutes summerOnly name) = 76 | [ tz { Time.timeZoneMinutes = m' } | m' <- shrink minutes ] ++ 77 | [ tz { Time.timeZoneSummerOnly = s' } | s' <- shrink summerOnly ] ++ 78 | [ tz { Time.timeZoneName = n' } | n' <- shrink name ] 79 | 80 | instance CoArbitrary Time.TimeZone where 81 | coarbitrary (Time.TimeZone minutes summerOnly name) = 82 | coarbitrary minutes . coarbitrary summerOnly . coarbitrary name 83 | 84 | instance Arbitrary Time.TimeOfDay where 85 | arbitrary = 86 | Time.TimeOfDay 87 | <$> choose (0, 23) -- hour 88 | <*> choose (0, 59) -- minute 89 | <*> (fromRational . toRational <$> choose (0::Double, 60)) -- picoseconds, via double 90 | shrink tod@(Time.TimeOfDay hour minute second) = 91 | [ tod { Time.todHour = h' } | h' <- shrink hour ] ++ 92 | [ tod { Time.todMin = m' } | m' <- shrink minute ] ++ 93 | [ tod { Time.todSec = s' } | s' <- shrink second ] 94 | 95 | instance CoArbitrary Time.TimeOfDay where 96 | coarbitrary (Time.TimeOfDay hour minute second) = 97 | coarbitrary hour . coarbitrary minute . coarbitrary second 98 | 99 | instance Arbitrary Time.LocalTime where 100 | arbitrary = 101 | Time.LocalTime 102 | <$> arbitrary 103 | <*> arbitrary 104 | shrink lt@(Time.LocalTime day tod) = 105 | [ lt { Time.localDay = d' } | d' <- shrink day ] ++ 106 | [ lt { Time.localTimeOfDay = t' } | t' <- shrink tod ] 107 | 108 | instance CoArbitrary Time.LocalTime where 109 | coarbitrary (Time.LocalTime day tod) = 110 | coarbitrary day . coarbitrary tod 111 | 112 | instance Arbitrary Time.ZonedTime where 113 | arbitrary = 114 | Time.ZonedTime 115 | <$> arbitrary 116 | <*> arbitrary 117 | shrink zt@(Time.ZonedTime lt zone) = 118 | [ zt { Time.zonedTimeToLocalTime = l' } | l' <- shrink lt ] ++ 119 | [ zt { Time.zonedTimeZone = z' } | z' <- shrink zone ] 120 | 121 | instance CoArbitrary Time.ZonedTime where 122 | coarbitrary (Time.ZonedTime lt zone) = 123 | coarbitrary lt . coarbitrary zone 124 | 125 | instance Arbitrary Time.AbsoluteTime where 126 | arbitrary = 127 | Time.addAbsoluteTime 128 | <$> arbitrary 129 | <*> return Time.taiEpoch 130 | shrink at = 131 | (`Time.addAbsoluteTime` at) <$> shrink (Time.diffAbsoluteTime at Time.taiEpoch) 132 | 133 | instance CoArbitrary Time.AbsoluteTime where 134 | coarbitrary = coarbitrary . flip Time.diffAbsoluteTime Time.taiEpoch 135 | 136 | 137 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/Mutation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ViewPatterns#-} 3 | {-# LANGUAGE FlexibleInstances,UndecidableInstances#-} 4 | {-# LANGUAGE CPP #-} 5 | 6 | module Test.QuickFuzz.Derive.Mutation where 7 | 8 | import Language.Haskell.TH 9 | import Language.Haskell.TH.Syntax 10 | 11 | import Test.QuickCheck 12 | import Control.Monad 13 | import Control.Arrow 14 | import Control.Applicative 15 | import Data.List 16 | 17 | import Megadeth.Prim 18 | import Test.QuickFuzz.Derive.Mutators 19 | 20 | #if MIN_VERSION_template_haskell(2,11,0) 21 | # define TH211MBKIND _maybe_kind 22 | #else 23 | # define TH211MBKIND 24 | #endif 25 | 26 | --import Mutation 27 | -- 28 | -- | Mutation Class 29 | class Mutation a where 30 | --mutt' :: Int -> a -> Gen a 31 | mutt :: a -> Gen a -- ^ Given a value, mutate it. 32 | --mutt = mutt' 10 33 | --mut :: Gen a 34 | 35 | instance {-#OVERLAPS#-} (Mutation a, Arbitrary a) => Mutation [a] where 36 | mutt xs = frequency $ [(10, mapM mutt xs), 37 | (1, expander xs), 38 | (1, deleter xs), 39 | (1, swaper xs), 40 | (1, repeater xs), 41 | (1, return xs)] 42 | 43 | instance {-#OVERLAPS#-} Arbitrary a => Mutation a where 44 | mutt a = frequency $ [ (20, return a), (1,arbitrary)] 45 | 46 | howm :: Con -> (Name, Int) 47 | howm (NormalC n xs) = (n,length xs) 48 | howm (RecC n xs) = (n,length xs) 49 | howm (ForallC _ _ t) = howm t 50 | howm (InfixC _ _ _ ) = error "not yet" 51 | 52 | as :: [Name] 53 | as = map (\x -> mkName $ 'a':show x) ([1..] :: [Int]) 54 | 55 | -- TODO: ViewPattern, recursive? 56 | -- + mutt (C a1 a2 .. an) = do 57 | -- a1' <- frequency [(10,return a1), (1,arbitrary), (1, mutt a1)] 58 | -- ... 59 | -- return $ C a1' a2' ... 60 | -- This is extremely expensive, isn't it? 61 | 62 | freqE :: Bool -> Name -> ExpQ 63 | freqE _ var = 64 | appE 65 | (varE 'frequency) 66 | (listE 67 | [ tupE [litE $ integerL 20, (appE (varE 'mutt) (varE var))] 68 | , tupE [litE $ integerL 20, (appE (varE 'return) (varE var))] 69 | , tupE [litE $ integerL 1, varE 'arbitrary] -- Here we could use a custom Gen 70 | ]) 71 | 72 | muttC :: Name -> [(Bool,Name)] -> ExpQ 73 | muttC c [] = 74 | appE 75 | (varE 'frequency) 76 | (listE 77 | [ 78 | tupE [litE $ integerL 20, 79 | (appE (varE 'return) (conE c)) ] 80 | , tupE [litE $ integerL 1, varE 'arbitrary] 81 | -- , tupE [litE $ integerL 1, varE 'mut] -- Here we could use a custom Gen 82 | ]) 83 | muttC c vars = doE $ map (\ (b,x) -> bindS (varP x) (freqE b x)) vars 84 | ++ [ noBindS $ appE (varE 'return) 85 | $ foldl (\r (_,x) -> appE r (varE x)) (conE c) vars] 86 | 87 | isMutInsName = isinsName ''Mutation 88 | 89 | ifsymHeadOf :: Name -> Q Name 90 | ifsymHeadOf n = do 91 | inf <- reify n 92 | case inf of 93 | TyConI (TySynD _ _ t) -> return $ headOf t 94 | _ -> return n 95 | 96 | 97 | devMutation :: Name -> Q [Dec] 98 | devMutation t = do 99 | deps <- prevDev t (\_ -> return False) 100 | nosym <- mapM ifsymHeadOf deps 101 | let deps' = nub $ filter (not . hasArbIns) nosym -- Get rid of all type syn ? 102 | -- Just ignore typesym later... We hope that prevDev get all dependencies 103 | -- all right, if not, we always have Arb => Mutation 104 | --dps <- filterM isMutInsName deps' -- Arbitrary => Mutation :( 105 | ds <- mapM ((flip devMutation') Nothing) deps' 106 | return $ concat ds 107 | 108 | devMutation' :: Name -> Maybe Name -> Q [Dec] 109 | devMutation' name customGen = do 110 | def <- reify name 111 | case def of -- We need constructors... 112 | TyConI (TySynD _ _ ty) -> return [] -- devMutation (headOf ty) Nothing 113 | TyConI (DataD _ _ params TH211MBKIND constructors _) -> do 114 | let fnm = mkName $ "mutt" -- ++ (showName name) 115 | let f = funD fnm $ foldl (\ p c -> 116 | let 117 | SimpleCon n rec vs = simpleConView name c 118 | tfs = map (\ ty -> (countCons (== name) ty > 0)) vs 119 | vars = take (length vs) as 120 | vp = map varP vars 121 | in 122 | (clause [conP n vp] (normalB $ muttC n (zip tfs vars)) []) 123 | : p) [] constructors 124 | let ns = map varT $ paramNames params 125 | if length ns > 0 then 126 | case customGen of 127 | Nothing -> do 128 | dec <- instanceD (cxt $ (map (appT (conT ''Arbitrary)) ns) ++ (map (appT (conT ''Mutation)) ns)) 129 | ( appT (conT ''Mutation) (applyTo (conT name) ns)) 130 | [f] 131 | return [dec] 132 | Just g -> do 133 | dec <- instanceD (cxt $ (map (appT (conT ''Arbitrary)) ns) ++ (map (appT (conT ''Mutation)) ns)) 134 | ( appT (conT ''Mutation) (applyTo (conT name) ns)) 135 | [f] 136 | return [dec] 137 | else do 138 | case customGen of 139 | Nothing -> do 140 | dec <- instanceD (cxt []) [t| Mutation $(applyTo (conT name) ns) |] [f] 141 | return $ dec : [] 142 | Just g -> do 143 | dec <- instanceD (cxt []) [t| Mutation $(applyTo (conT name) ns) |] [f] 144 | return $ dec : [] 145 | a -> return [] --return [f] 146 | -- TyConI (NewtypeD _ _ params con _) -> do 147 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Gen/Base/Regex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE IncoherentInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Test.QuickFuzz.Gen.Base.Regex where 6 | 7 | import Control.DeepSeq 8 | import Data.Default 9 | import Data.Char (chr) 10 | import Data.List (intersperse, partition, subsequences) 11 | import Data.Set (Set) 12 | import qualified Data.Set as Set (toAscList, toList) 13 | import qualified Data.ByteString.Lazy as L 14 | import qualified Data.ByteString.Lazy.Char8 as LC8 15 | 16 | import Test.QuickCheck hiding (shrink) 17 | import Test.QuickFuzz.Derive 18 | import Test.QuickFuzz.Derive.Generator 19 | import Test.QuickFuzz.Derive.NFData 20 | import Test.QuickFuzz.Gen.Base.ByteString 21 | import Test.QuickFuzz.Gen.FormatInfo 22 | 23 | 24 | data Pattern = PEmpty | PCarat | PDollar 25 | | PGroup PatternIndex Pattern 26 | -- | PGroup' PatternIndex (Maybe PatternIndex) Pattern -- used in longest match 27 | | POr [Pattern] 28 | | PConcat [Pattern] 29 | | PQuest Pattern 30 | | PPlus Pattern 31 | | PStar Pattern 32 | | PBound Int (Maybe Int) Pattern 33 | -- | PLazy indicates the pattern should find the shortest match first 34 | | PLazy Pattern -- non-greedy wrapper (for ?+*{} followed by ?) 35 | -- | PPossessive indicates the pattern can only find the longest match 36 | | PPossessive Pattern -- possessive modifier (for ?+*{} followed by +) 37 | | PDot -- Any character (newline?) at all 38 | | PAny PatternSet -- Square bracketed things 39 | | PAnyNot PatternSet -- Inverted square bracketed things 40 | | PEscape Char -- Backslashed Character 41 | | PBack PatternIndex -- Backslashed digits as natural number 42 | | PChar Char -- Specific Character 43 | -- After simplify / mergeCharToString, adjacent PChar are merge'd into PString 44 | | PString String 45 | deriving (Eq,Show) 46 | 47 | showPattern :: Pattern -> String 48 | showPattern pIn = 49 | case pIn of 50 | PEmpty -> "()" 51 | PCarat -> "^" 52 | PDollar -> "$" 53 | PGroup _ p -> ('(':showPattern p)++")" 54 | POr ps -> concat $ intersperse "|" (map showPattern ps) 55 | PConcat ps -> concatMap showPattern ps 56 | PQuest p -> (showPattern p)++"?" 57 | PPlus p -> (showPattern p)++"+" 58 | PStar p -> (showPattern p)++"*" 59 | PLazy p -> (showPattern p)++"?" 60 | -- | otherwise -> "" 61 | PPossessive p -> (showPattern p)++"+" 62 | -- | otherwise -> "" 63 | PBound i (Just j) p | i==j -> showPattern p ++ ('{':show i)++"}" 64 | PBound i mj p -> showPattern p ++ ('{':show i) ++ maybe ",}" (\j -> ',':show j++"}") mj 65 | PDot -> "." 66 | PAny (PatternSet s scc sce sec) -> 67 | let (special,normal) = maybe ("","") ((partition (`elem` "]-")) . Set.toAscList) s 68 | charSpec = (if ']' `elem` special then (']':) else id) (byRange normal) 69 | scc' = maybe "" ((concatMap (\ss -> "[:"++unSCC ss++":]")) . Set.toList) scc 70 | sce' = maybe "" ((concatMap (\ss -> "[."++unSCE ss++".]")) . Set.toList) sce 71 | sec' = maybe "" ((concatMap (\ss -> "[="++unSEC ss++"=]")) . Set.toList) sec 72 | in concat ['[':charSpec,scc',sce',sec',if '-' `elem` special then "-]" else "]"] 73 | PAnyNot (PatternSet s scc sce sec) -> 74 | let (special,normal) = maybe ("","") ((partition (`elem` "]-")) . Set.toAscList) s 75 | charSpec = (if ']' `elem` special then (']':) else id) (byRange normal) 76 | scc' = maybe "" ((concatMap (\ss -> "[:"++unSCC ss++":]")) . Set.toList) scc 77 | sce' = maybe "" ((concatMap (\ss -> "[."++unSCE ss++".]")) . Set.toList) sce 78 | sec' = maybe "" ((concatMap (\ss -> "[="++unSEC ss++"=]")) . Set.toList) sec 79 | in concat ["[^",charSpec,scc',sce',sec',if '-' `elem` special then "-]" else "]"] 80 | PEscape c -> '\\':c:[] 81 | PBack i -> '\\':(show i) 82 | PChar c -> [c] 83 | PString s -> s 84 | where byRange xAll@(x:xs) | length xAll <=3 = xAll 85 | | otherwise = groupRange x 1 xs 86 | byRange _ = "" 87 | groupRange x n (y:ys) = if (fromEnum y)-(fromEnum x) == n then groupRange x (succ n) ys 88 | else (if n <=3 then take n [x..] 89 | else x:'-':(toEnum (pred n+fromEnum x)):[]) ++ groupRange y 1 ys 90 | groupRange x n [] = if n <=3 then take n [x..] 91 | else x:'-':(toEnum (pred n+fromEnum x)):[] 92 | 93 | 94 | data PatternSet = PatternSet (Maybe (Set Char)) (Maybe (Set (PatternSetCharacterClass))) 95 | (Maybe (Set PatternSetCollatingElement)) (Maybe (Set PatternSetEquivalenceClass)) deriving (Eq,Show) 96 | 97 | newtype PatternSetCharacterClass = PatternSetCharacterClass {unSCC::String} deriving (Eq,Ord,Show) -- [: :] 98 | newtype PatternSetCollatingElement = PatternSetCollatingElement {unSCE::String} deriving (Eq,Ord,Show) -- [. .] 99 | newtype PatternSetEquivalenceClass = PatternSetEquivalenceClass {unSEC::String} deriving (Eq,Ord,Show) -- [= =] 100 | 101 | -- | PatternIndex is for indexing submatches from parenthesized groups (PGroup) 102 | type PatternIndex = Int 103 | 104 | -- helper function 105 | isPostAtom :: Pattern -> Bool 106 | isPostAtom p = case p of 107 | PQuest _ -> True 108 | PPlus _ -> True 109 | PStar _ -> True 110 | PBound _ _ _ -> True 111 | _ -> False 112 | 113 | $(devArbitrary ''Pattern) 114 | $(devNFData ''Pattern) 115 | $(devGenerator "genPattern" ''Pattern) 116 | 117 | type Regex = Pattern 118 | 119 | 120 | shrinkRegex :: Regex -> [Regex] 121 | shrinkRegex PEmpty = [] 122 | shrinkRegex PCarat = [] 123 | shrinkRegex PDollar = [] 124 | shrinkRegex PDot = [] 125 | shrinkRegex x = [PEmpty, PCarat, PDollar, PDot] ++ shrinkRegex' x 126 | 127 | shrinkRegex' PEmpty = [PEmpty] 128 | shrinkRegex' PCarat = [PCarat] 129 | shrinkRegex' PDollar = [PDollar] 130 | shrinkRegex' PDot = [PDot] 131 | shrinkRegex' (PGroup i p) = [p] ++ [PGroup i' p' | i' <- shrinkInt i, p' <- shrinkRegex' p] 132 | shrinkRegex' (POr ps) = [POr ps'' | ps'' <- subsequences ps, ps' <- shrinkListOfPattern ps] 133 | shrinkRegex' (PConcat ps) = [POr ps' | ps' <- shrinkListOfPattern ps] 134 | shrinkRegex' (PQuest p) = [p] ++ [PQuest p' | p' <- shrinkRegex' p] 135 | shrinkRegex' (PPlus p) = [p] ++ [PPlus p' | p' <- shrinkRegex' p] 136 | shrinkRegex' (PStar p) = [p] ++[PStar p' | p' <- shrinkRegex' p] 137 | shrinkRegex' (PBound i mi p) = [p] ++ [PBound i' mi' p'| i' <- shrinkInt i, mi' <- shrinkMaybe mi, p' <- shrinkRegex' p] 138 | shrinkRegex' (PLazy p) = [p] ++[PLazy p' | p' <- shrinkRegex' p] 139 | shrinkRegex' (PPossessive p) = [p] ++ [PPossessive p' | p' <- shrinkRegex' p] 140 | shrinkRegex' (PAny pset) = [PAny pset' | pset' <- shrinkPatternSet pset] 141 | shrinkRegex' (PAnyNot pset) = [PAnyNot pset' | pset' <- shrinkPatternSet pset] 142 | shrinkRegex' (PEscape c) = [PEscape c' | c' <- shrinkChar c] 143 | shrinkRegex' (PBack pi) = [PBack pi' | pi' <- shrinkPatternIndex pi] 144 | shrinkRegex' (PChar c) = [PChar c' | c' <- shrinkChar c] 145 | shrinkRegex' (PString str) = [PString str' | str' <- shrinkString str] 146 | 147 | 148 | shrinkInt x = [x] 149 | shrinkMaybe x = [x] 150 | shrinkPatternSet x = [x] 151 | shrinkPatternIndex x = [x] 152 | shrinkChar c = [c] 153 | shrinkString = subsequences 154 | shrinkListOfPattern xs = map shrinkRegex' xs 155 | 156 | 157 | mencode :: Regex -> LC8.ByteString 158 | mencode x = LC8.pack $ "/" ++ showPattern x ++ "/" 159 | 160 | regexInfo :: FormatInfo Regex NoActions 161 | regexInfo = def 162 | { encode = mencode 163 | , random = arbitrary 164 | , value = show 165 | , shrink = shrinkRegex 166 | , ext = "regex" 167 | } 168 | -------------------------------------------------------------------------------- /QuickFuzz.cabal: -------------------------------------------------------------------------------- 1 | name: QuickFuzz 2 | version: 0.1.0.0 3 | synopsis: An experimental grammar fuzzer in Haskell using QuickCheck. 4 | license: GPL-3 5 | license-file: LICENSE 6 | author: Pablo Buiras , 7 | Gustavo Grieco , 8 | Martín Ceresa 9 | Martín Escarrá 10 | Agustín Mista 11 | 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | flag debug 17 | description: Enable debug messages 18 | default: False 19 | 20 | flag image 21 | Description: Supports Tga, Png, Bmp, Jpeg, Tiff and Gif formats. 22 | Default: False 23 | Manual: True 24 | 25 | flag arch 26 | Description: Supports ... formats. 27 | Default: False 28 | Manual: True 29 | 30 | flag code 31 | Description: Supports ... formats. 32 | Default: False 33 | Manual: True 34 | 35 | flag doc 36 | Description: Supports ... formats. 37 | Default: False 38 | Manual: True 39 | 40 | flag media 41 | Description: Supports ... formats. 42 | Default: False 43 | Manual: True 44 | 45 | flag pki 46 | Description: Supports ... formats. 47 | Default: False 48 | Manual: True 49 | 50 | flag net 51 | Description: Supports ... formats. 52 | Default: False 53 | Manual: True 54 | 55 | flag bnfc 56 | Description: Supports bnfc grammer formats. 57 | Default: False 58 | Manual: True 59 | 60 | flag all 61 | Description: Enables all file formats 62 | Default: False 63 | Manual: True 64 | 65 | 66 | library 67 | hs-source-dirs: src 68 | exposed-modules: 69 | Test.QuickFuzz.Derive 70 | Test.QuickFuzz.Derive.Actions 71 | Test.QuickFuzz.Derive.Mutation 72 | Test.QuickFuzz.Derive.Mutators 73 | Test.QuickFuzz.Derive.Arbitrary 74 | Test.QuickFuzz.Derive.Generator 75 | Test.QuickFuzz.Derive.Show 76 | Test.QuickFuzz.Derive.NFData 77 | Test.QuickFuzz.Derive.Fixable 78 | Test.QuickFuzz.Gen.Base 79 | Test.QuickFuzz.Gen.Base.Value 80 | Test.QuickFuzz.Gen.Base.ByteString 81 | Test.QuickFuzz.Gen.Base.Regex 82 | Test.QuickFuzz.Gen.Base.String 83 | Test.QuickFuzz.Gen.Base.Time 84 | Test.QuickFuzz.Gen.Base.Unicode 85 | Test.QuickFuzz.Gen.Base.Vector 86 | Test.QuickFuzz.Gen.FormatInfo 87 | Test.QuickFuzz.Global 88 | 89 | build-depends: 90 | base, bytestring, QuickCheck, megadeth, template-haskell, vector, 91 | ghc-prim, split, text, containers, time, derive, binary, mtl, 92 | transformers, ghc-mod, haskell-src-exts, haskell-src-meta, 93 | global-variables, deepseq, data-default 94 | 95 | if flag(arch) || flag(all) 96 | cpp-options: -DARCH 97 | exposed-modules: 98 | Test.QuickFuzz.Gen.Archive 99 | Test.QuickFuzz.Gen.Archive.Tar 100 | Test.QuickFuzz.Gen.Archive.Zip 101 | 102 | build-depends: 103 | tar, zip-archive 104 | 105 | if flag(media) || flag(all) 106 | cpp-options: -DMEDIA 107 | exposed-modules: 108 | Test.QuickFuzz.Gen.Media 109 | Test.QuickFuzz.Gen.Media.Wav 110 | 111 | build-depends: 112 | wavy 113 | 114 | if flag(doc) || flag(all) 115 | cpp-options: -DDOC 116 | exposed-modules: 117 | Test.QuickFuzz.Gen.Document 118 | Test.QuickFuzz.Gen.Document.Html 119 | Test.QuickFuzz.Gen.Document.Css 120 | Test.QuickFuzz.Gen.Document.PDF 121 | Test.QuickFuzz.Gen.Document.PS 122 | Test.QuickFuzz.Gen.Document.EPS 123 | Test.QuickFuzz.Gen.Document.Xml 124 | 125 | build-depends: 126 | blaze-html, blaze-markup, easyrender, HaXml, xmlgen, blaze-builder, language-css, pretty 127 | 128 | if flag(code) || flag(all) 129 | cpp-options: -DCODE 130 | exposed-modules: 131 | Test.QuickFuzz.Gen.Code 132 | Test.QuickFuzz.Gen.Code.C 133 | Test.QuickFuzz.Gen.Code.Js 134 | Test.QuickFuzz.Gen.Code.Python 135 | Test.QuickFuzz.Gen.Code.Go 136 | Test.QuickFuzz.Gen.Code.Lua 137 | Test.QuickFuzz.Gen.Code.Evm 138 | Test.QuickFuzz.Gen.Code.GLSL 139 | 140 | build-depends: 141 | language-c, language-ecmascript, language-python, language-go, language-lua, ethereum-analyzer-deps, language-glsl, pretty 142 | 143 | if flag(image) || flag(all) 144 | cpp-options: -DIMAGE 145 | exposed-modules: 146 | Test.QuickFuzz.Gen.Base.Image 147 | Test.QuickFuzz.Gen.Image 148 | Test.QuickFuzz.Gen.Image.SVG 149 | Test.QuickFuzz.Gen.Image.Gif 150 | Test.QuickFuzz.Gen.Image.Png 151 | Test.QuickFuzz.Gen.Image.Tiff 152 | Test.QuickFuzz.Gen.Image.Jpeg 153 | Test.QuickFuzz.Gen.Image.Tga 154 | 155 | build-depends: 156 | JuicyPixels, svg-tree, xml 157 | 158 | if flag(pki) || flag(all) 159 | cpp-options: -DPKI 160 | exposed-modules: 161 | Test.QuickFuzz.Gen.Pki 162 | Test.QuickFuzz.Gen.Pki.ASN1 163 | Test.QuickFuzz.Gen.Pki.X509 164 | Test.QuickFuzz.Gen.Pki.CRL 165 | 166 | build-depends: asn1-types, asn1-encoding, x509, cryptonite, hourglass 167 | 168 | 169 | if flag(net) || flag(all) 170 | cpp-options: -DNET 171 | exposed-modules: 172 | Test.QuickFuzz.Gen.Network 173 | Test.QuickFuzz.Gen.Network.HTTP 174 | 175 | build-depends: 176 | HTTP 177 | 178 | 179 | if flag(bnfc) || flag(all) 180 | cpp-options: -DBNFC 181 | exposed-modules: 182 | Test.QuickFuzz.Gen.Bnfc 183 | Test.QuickFuzz.Gen.Bnfc.Grammar 184 | Test.QuickFuzz.Gen.Bnfc.AbsGrammar 185 | Test.QuickFuzz.Gen.Bnfc.PrintGrammar 186 | build-depends: 187 | BNFC 188 | 189 | default-language: Haskell2010 190 | ghc-options: -O2 -optc-O3 -threaded -rtsopts 191 | 192 | 193 | executable QuickFuzz 194 | hs-source-dirs: app 195 | main-is: Main.hs 196 | other-modules: 197 | Args 198 | Fuzzers 199 | Debug 200 | Exception 201 | Formats 202 | DeriveDispatcher 203 | Process 204 | Utils 205 | Utils.Generation 206 | Utils.Decoding 207 | Utils.Mutation 208 | Utils.Patch 209 | Utils.Console 210 | Utils.Shrink 211 | Utils.Unique 212 | Run.GenTest 213 | Run.MutTest 214 | Run.Gen 215 | Run.Serve 216 | Run.Exec 217 | Run.Shrink 218 | Run.List 219 | 220 | if flag(debug) 221 | cpp-options: -DDEBUG 222 | if flag(arch) || flag(all) 223 | cpp-options: -DARCH 224 | if flag(media) || flag(all) 225 | cpp-options: -DMEDIA 226 | if flag(doc) || flag(all) 227 | cpp-options: -DDOC 228 | if flag(code) || flag(all) 229 | cpp-options: -DCODE 230 | if flag(image) || flag(all) 231 | cpp-options: -DIMAGE 232 | if flag(pki) || flag(all) 233 | cpp-options: -DPKI 234 | if flag(bnfc) || flag(all) 235 | cpp-options: -DBNFC 236 | if flag(net) || flag(all) 237 | cpp-options: -DNET 238 | build-depends: 239 | network 240 | 241 | other-extensions: 242 | CPP, ViewPatterns 243 | 244 | build-depends: 245 | QuickFuzz, base, bytestring, QuickCheck, argparser, split, containers, 246 | template-haskell, filepath, directory, ansi-terminal, time, process, 247 | silently, parallel, deepseq, random, process-extras, network, unix, 248 | global-variables, Diff, stringsearch 249 | 250 | default-language: Haskell2010 251 | ghc-options: -O2 -optc-O3 -threaded -rtsopts -ddump-splices 252 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/Generator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Test.QuickFuzz.Derive.Generator ( 5 | devGenerator 6 | ) where 7 | 8 | import Megadeth.Prim 9 | 10 | import Language.Haskell.TH 11 | import Language.Haskell.TH.Syntax as TH 12 | import Test.QuickCheck 13 | 14 | import Control.Monad 15 | import GHC.Types 16 | 17 | import Data.List 18 | import qualified Data.Map.Strict as M 19 | 20 | #if MIN_VERSION_template_haskell(2,11,0) 21 | # define TH211MBKIND _maybe_kind 22 | #else 23 | # define TH211MBKIND 24 | #endif 25 | 26 | type Functorial = ([Type],[Name]) 27 | 28 | headOf' :: Type -> Maybe Name 29 | headOf' (AppT ListT ty) = Nothing 30 | headOf' (AppT (TupleT _) ty) = Nothing 31 | headOf' (AppT ArrowT e) = headOf' e 32 | headOf' (AppT ty1 _) = headOf' ty1 33 | headOf' (SigT ty _) = headOf' ty 34 | headOf' (ConT n) = Just n 35 | headOf' (VarT n) = Just n 36 | headOf' e = error ("Missing :" ++ show e) 37 | 38 | -- | Find all simple Types that are arguments of another Type. 39 | findArgTypes :: Type -> [Type] 40 | findArgTypes a@(AppT ListT _) = [a] 41 | findArgTypes a@(AppT (TupleT n) _) = [a] 42 | findArgTypes (AppT p@(ConT _) ty) = findArgTypes ty 43 | findArgTypes (AppT ty1 ty2) = findArgTypes ty1 ++ findArgTypes ty2 44 | findArgTypes a@(VarT _) = [a] 45 | findArgTypes (ForallT _ _ ty) = findArgTypes ty 46 | findArgTypes ArrowT = [] 47 | findArgTypes ListT = [] 48 | findArgTypes StarT = [] 49 | findArgTypes ty = [ty] 50 | 51 | -- | Substitution 52 | subst :: Type -> Name -> Type -> Maybe Type 53 | subst (VarT v) n t | v == n = Just t 54 | subst (AppT l r) n t = 55 | case (subst l n t, subst r n t) of 56 | (Just l', Just r') -> Just $ AppT l' r' 57 | (Just l', Nothing) -> Just $ AppT l' r 58 | (Nothing, Just r') -> Just $ AppT l r' 59 | _ -> Nothing 60 | subst (ForallT a b ty) n t = subst ty n t >>= (Just . ForallT a b) 61 | subst _ _ _ = Nothing 62 | 63 | helpa :: Name -> Functorial 64 | -> Name -> M.Map Type Name -> Type -> ExpQ 65 | helpa rs fr nm m (ConT t) = if nm == t then 66 | varE rs 67 | else error " Error in helper function " 68 | helpa rs fr nm m (AppT l r) = appE (helpa rs fr nm m l) (varE $ lookUp m r) 69 | 70 | lookUp :: M.Map Type Name -> Type -> Name 71 | lookUp m t = M.findWithDefault (error $ "Not found " ++ show t) t m 72 | 73 | pseudogetLeaf :: Type -> [Type] 74 | pseudogetLeaf (AppT l r) = r : pseudogetLeaf l 75 | pseudogetLeaf (ConT _) = [] 76 | pseudogetLeaf x = error $ "Missing " ++ show x 77 | 78 | rep :: M.Map Name Type -> Type -> Type 79 | rep m ListT = ListT 80 | rep m (VarT x) = if M.member x m then m M.! x else VarT x 81 | rep _ (ConT c) = ConT c 82 | rep m (AppT l r) = AppT (rep m l) $ rep m r 83 | rep _ t = error $ "Missing: " ++ show t 84 | 85 | unif :: Functorial -> [Type] -> [Type] 86 | unif f@(gargs, bnds) args = 87 | if length bnds /= length args 88 | then error $ "diff sizes?" ++ show f -- safety check, it should not happen 89 | else 90 | let mp = M.fromList $ zip bnds args 91 | in map (rep mp) gargs 92 | 93 | checkDiff :: (Eq a) => Maybe a -> a -> Bool 94 | checkDiff Nothing _ = True 95 | checkDiff (Just x) y = x /= y 96 | genGen' :: Name 97 | -> Functorial 98 | -> Name 99 | -> M.Map Type Name 100 | -> Type -> ExpQ -- Recursive case missing 101 | genGen' rs fr nm m t = 102 | if checkDiff (headOf' t) nm 103 | then varE $ lookUp m t 104 | else 105 | let ins = reverse $ pseudogetLeaf t 106 | in genRecGen $ unif fr ins 107 | where 108 | genRecGen :: [Type] -> ExpQ 109 | genRecGen xs = 110 | foldl appE (varE rs) 111 | $ map (varE . lookUp m) xs 112 | 113 | genGen :: Name -- Recursive name, given by the user 114 | -> Functorial -- Recursive functorial. 115 | -> Name -- Top type name. 116 | -> M.Map Type Name -- Environment 117 | -> [Type] -- Constructor argument types as in C_i [Type] 118 | -> ExpQ -- Result expression, genT_1 <*> genT_2 <*> genT_3 ... 119 | genGen rs fr nm m ts = foldr1 120 | (\x xs -> uInfixE x (varE '(<*>)) xs) 121 | $ map (genGen' rs fr nm m) ts 122 | 123 | 124 | recuded' :: Name -> Type -> (M.Map Type Name, [[Type]]) -> Q ((M.Map Type Name) , [[Type]]) 125 | recuded' nm t (rs,tss) = if checkDiff (headOf' t) nm then 126 | do 127 | runIO $ print $ "Added: " ++ show t 128 | n <- newName "gen" 129 | return (M.insert t n rs,tss) 130 | else 131 | -- do runIO $ print "Args?" 132 | -- runIO $ print $ findArgTypes t 133 | return (rs, (findArgTypes t) : tss) 134 | -- foldM (\rs t -> recuded' nm t rs ) 135 | -- rs 136 | -- (filter ((nm /=) . headOf) (findLeafTypes t)) 137 | 138 | -- Search for the types that are known and needed. 139 | -- Each one of these types will be an argument, hence 140 | -- this function also generate the names of those arguments. 141 | recuded :: Name -> [Type] -> Q ((M.Map Type Name) , [[Type]]) 142 | recuded nm ts = foldM (\rs t -> recuded' nm t rs) (M.empty,[]) ts 143 | 144 | devGenerator :: String -> Name -> Q [Dec] 145 | devGenerator f nm = do 146 | inf <- reify nm 147 | case inf of 148 | TyConI (DataD _ _ params TH211MBKIND cons _ ) -> do 149 | let paramNm = paramNames params 150 | ns = map varT paramNm 151 | scons = map (simpleConView nm) cons 152 | needed = concat $ map tt scons 153 | let fnm = mkName f 154 | -- search for types 155 | (mapTN', tss) <- recuded nm needed 156 | let instan = map (zip paramNm) tss 157 | mapTN <- foldM (\m is -> 158 | foldM (\m (v,t) -> do 159 | let rs = (M.foldrWithKey (\k l res -> 160 | let r = subst k v t in 161 | case r of 162 | Nothing -> res 163 | Just r' -> r' : res) 164 | [] m) 165 | foldM (\m t -> do 166 | -- runIO $ print $ "Added: " ++ show t 167 | n <- newName "gen" 168 | return $ M.insert t n m) m rs ) m is 169 | ) mapTN' instan 170 | -- Debugging 171 | -- runIO $ print "Ya están" 172 | -- runIO $ print mapTN 173 | -- runIO $ print "Faltantes" 174 | -- runIO $ print tss 175 | -- runIO $ print "Instancias " 176 | -- runIO $ print mapTN' 177 | -- Debugging 178 | let gsPatt = map varP $ M.elems mapTN 179 | let funct = M.keys mapTN -- these are the types of the arguments. 180 | signature <- sigD fnm (forallT params (cxt []) 181 | (foldr 182 | (\x xs -> appT (appT arrowT 183 | (appT (conT ''Gen) 184 | $ return x)) xs) 185 | (appT 186 | (conT ''Gen) 187 | $ applyTo (conT nm) ns) 188 | funct 189 | ) 190 | ) 191 | let fnmFunc = (funct, paramNm) 192 | fb <- funD fnm [clause gsPatt (normalB $ 193 | [| oneof 194 | $(listE $ map (\(SimpleCon cnm _ t) -> 195 | if null t then 196 | appE (varE 'pure) (conE cnm) 197 | else 198 | uInfixE (conE cnm) (varE '(<$>)) 199 | $ genGen fnm fnmFunc nm mapTN t 200 | ) scons) 201 | |] 202 | ) [] 203 | ] 204 | return [signature, fb] 205 | _ -> error "Complex data constructors." 206 | -------------------------------------------------------------------------------- /doc/haskell-style.md: -------------------------------------------------------------------------------- 1 | Haskell Style Guide 2 | =================== 3 | 4 | This is a short document describing the preferred coding style for 5 | this project. I've tried to cover the major areas of formatting and 6 | naming. When something isn't covered by this guide you should stay 7 | consistent with the code in the other modules. 8 | 9 | Formatting 10 | ---------- 11 | 12 | ### Line Length 13 | 14 | Maximum line length is *80 characters*. 15 | 16 | ### Indentation 17 | 18 | Tabs are illegal. Use spaces for indenting. Indent your code blocks 19 | with *4 spaces*. Indent the `where` keyword two spaces to set it 20 | apart from the rest of the code and indent the definitions in a 21 | `where` clause 2 spaces. Some examples: 22 | 23 | ```haskell 24 | sayHello :: IO () 25 | sayHello = do 26 | name <- getLine 27 | putStrLn $ greeting name 28 | where 29 | greeting name = "Hello, " ++ name ++ "!" 30 | 31 | filter :: (a -> Bool) -> [a] -> [a] 32 | filter _ [] = [] 33 | filter p (x:xs) 34 | | p x = x : filter p xs 35 | | otherwise = filter p xs 36 | ``` 37 | 38 | ### Blank Lines 39 | 40 | One blank line between top-level definitions. No blank lines between 41 | type signatures and function definitions. Add one blank line between 42 | functions in a type class instance declaration if the function bodies 43 | are large. Use your judgement. 44 | 45 | ### Whitespace 46 | 47 | Surround binary operators with a single space on either side. Use 48 | your better judgement for the insertion of spaces around arithmetic 49 | operators but always be consistent about whitespace on either side of 50 | a binary operator. Don't insert a space after a lambda. 51 | 52 | ### Data Declarations 53 | 54 | Align the constructors in a data type definition. Example: 55 | 56 | ```haskell 57 | data Tree a = Branch !a !(Tree a) !(Tree a) 58 | | Leaf 59 | ``` 60 | 61 | For long type names the following formatting is also acceptable: 62 | 63 | ```haskell 64 | data HttpException 65 | = InvalidStatusCode Int 66 | | MissingContentHeader 67 | ``` 68 | 69 | Format records as follows: 70 | 71 | ```haskell 72 | data Person = Person 73 | { firstName :: !String -- ^ First name 74 | , lastName :: !String -- ^ Last name 75 | , age :: !Int -- ^ Age 76 | } deriving (Eq, Show) 77 | ``` 78 | 79 | ### List Declarations 80 | 81 | Align the elements in the list. Example: 82 | 83 | ```haskell 84 | exceptions = 85 | [ InvalidStatusCode 86 | , MissingContentHeader 87 | , InternalServerError 88 | ] 89 | ``` 90 | 91 | Optionally, you can skip the first newline. Use your judgement. 92 | 93 | ```haskell 94 | directions = [ North 95 | , East 96 | , South 97 | , West 98 | ] 99 | ``` 100 | 101 | ### Pragmas 102 | 103 | Put pragmas immediately following the function they apply to. 104 | Example: 105 | 106 | ```haskell 107 | id :: a -> a 108 | id x = x 109 | {-# INLINE id #-} 110 | ``` 111 | 112 | In the case of data type definitions you must put the pragma before 113 | the type it applies to. Example: 114 | 115 | ```haskell 116 | data Array e = Array 117 | {-# UNPACK #-} !Int 118 | !ByteArray 119 | ``` 120 | 121 | ### Hanging Lambdas 122 | 123 | You may or may not indent the code following a "hanging" lambda. Use 124 | your judgement. Some examples: 125 | 126 | ```haskell 127 | bar :: IO () 128 | bar = forM_ [1, 2, 3] $ \n -> do 129 | putStrLn "Here comes a number!" 130 | print n 131 | 132 | foo :: IO () 133 | foo = alloca 10 $ \a -> 134 | alloca 20 $ \b -> 135 | cFunction a b 136 | ``` 137 | 138 | ### Export Lists 139 | 140 | Format export lists as follows: 141 | 142 | ```haskell 143 | module Data.Set 144 | ( 145 | -- * The @Set@ type 146 | Set 147 | , empty 148 | , singleton 149 | 150 | -- * Querying 151 | , member 152 | ) where 153 | ``` 154 | 155 | ### If-then-else clauses 156 | 157 | Generally, guards and pattern matches should be preferred over if-then-else 158 | clauses, where possible. Short cases should usually be put on a single line 159 | (when line length allows it). 160 | 161 | When writing non-monadic code (i.e. when not using `do`) and guards 162 | and pattern matches can't be used, you can align if-then-else clauses 163 | like you would normal expressions: 164 | 165 | ```haskell 166 | foo = if ... 167 | then ... 168 | else ... 169 | ``` 170 | 171 | Otherwise, you should be consistent with the 4-spaces indent rule, and the 172 | `then` and the `else` keyword should be aligned. Examples: 173 | 174 | ```haskell 175 | foo = do 176 | someCode 177 | if condition 178 | then someMoreCode 179 | else someAlternativeCode 180 | ``` 181 | 182 | ```haskell 183 | foo = bar $ \qux -> if predicate qux 184 | then doSomethingSilly 185 | else someOtherCode 186 | ``` 187 | 188 | The same rule applies to nested do blocks: 189 | 190 | ```haskell 191 | foo = do 192 | instruction <- decodeInstruction 193 | skip <- load Memory.skip 194 | if skip == 0x0000 195 | then do 196 | execute instruction 197 | addCycles $ instructionCycles instruction 198 | else do 199 | store Memory.skip 0x0000 200 | addCycles 1 201 | ``` 202 | 203 | ### Case expressions 204 | 205 | The alternatives in a case expression can be indented using either of 206 | the two following styles: 207 | 208 | ```haskell 209 | foobar = case something of 210 | Just j -> foo 211 | Nothing -> bar 212 | ``` 213 | 214 | or as 215 | 216 | ```haskell 217 | foobar = case something of 218 | Just j -> foo 219 | Nothing -> bar 220 | ``` 221 | 222 | Align the `->` arrows when it helps readability. 223 | 224 | Imports 225 | ------- 226 | 227 | Imports should be grouped in the following order: 228 | 229 | 1. standard library imports 230 | 2. related third party imports 231 | 3. local application/library specific imports 232 | 233 | Put a blank line between each group of imports. The imports in each 234 | group should be sorted alphabetically, by module name. 235 | 236 | Always use explicit import lists or `qualified` imports for standard 237 | and third party libraries. This makes the code more robust against 238 | changes in these libraries. Exception: The Prelude. 239 | 240 | Comments 241 | -------- 242 | 243 | ### Punctuation 244 | 245 | Write proper sentences; start with a capital letter and use proper 246 | punctuation. 247 | 248 | ### Top-Level Definitions 249 | 250 | Comment every top level function (particularly exported functions), 251 | and provide a type signature; use Haddock syntax in the comments. 252 | Comment every exported data type. Function example: 253 | 254 | ```haskell 255 | -- | Send a message on a socket. The socket must be in a connected 256 | -- state. Returns the number of bytes sent. Applications are 257 | -- responsible for ensuring that all data has been sent. 258 | send :: Socket -- ^ Connected socket 259 | -> ByteString -- ^ Data to send 260 | -> IO Int -- ^ Bytes sent 261 | ``` 262 | 263 | For functions the documentation should give enough information to 264 | apply the function without looking at the function's definition. 265 | 266 | Record example: 267 | 268 | ```haskell 269 | -- | Bla bla bla. 270 | data Person = Person 271 | { age :: !Int -- ^ Age 272 | , name :: !String -- ^ First name 273 | } 274 | ``` 275 | 276 | For fields that require longer comments format them like so: 277 | 278 | ```haskell 279 | data Record = Record 280 | { -- | This is a very very very long comment that is split over 281 | -- multiple lines. 282 | field1 :: !Text 283 | 284 | -- | This is a second very very very long comment that is split 285 | -- over multiple lines. 286 | , field2 :: !Int 287 | } 288 | ``` 289 | 290 | ### End-of-Line Comments 291 | 292 | Separate end-of-line comments from the code using 2 spaces. Align 293 | comments for data type definitions. Some examples: 294 | 295 | ```haskell 296 | data Parser = Parser 297 | !Int -- Current position 298 | !ByteString -- Remaining input 299 | 300 | foo :: Int -> Int 301 | foo n = salt * 32 + 9 302 | where 303 | salt = 453645243 -- Magic hash salt. 304 | ``` 305 | 306 | ### Links 307 | 308 | Use in-line links economically. You are encouraged to add links for 309 | API names. It is not necessary to add links for all API names in a 310 | Haddock comment. We therefore recommend adding a link to an API name 311 | if: 312 | 313 | * The user might actually want to click on it for more information (in 314 | your judgment), and 315 | 316 | * Only for the first occurrence of each API name in the comment (don't 317 | bother repeating a link) 318 | 319 | Naming 320 | ------ 321 | 322 | Use camel case (e.g. `functionName`) when naming functions and upper 323 | camel case (e.g. `DataType`) when naming data types. 324 | 325 | For readability reasons, don't capitalize all letters when using an 326 | abbreviation. For example, write `HttpServer` instead of 327 | `HTTPServer`. Exception: Two letter abbreviations, e.g. `IO`. 328 | 329 | ### Modules 330 | 331 | Use singular when naming modules e.g. use `Data.Map` and 332 | `Data.ByteString.Internal` instead of `Data.Maps` and 333 | `Data.ByteString.Internals`. 334 | 335 | Dealing with laziness 336 | --------------------- 337 | 338 | ### Functions 339 | 340 | Have function arguments be lazy unless you explicitly need them to be 341 | strict. 342 | 343 | The most common case when you need strict function arguments is in 344 | recursion with an accumulator: 345 | 346 | ```haskell 347 | mysum :: [Int] -> Int 348 | mysum = go 0 349 | where 350 | go !acc [] = acc 351 | go acc (x:xs) = go (acc + x) xs 352 | ``` 353 | 354 | Misc 355 | ---- 356 | 357 | ### Point-free style ### 358 | 359 | Avoid over-using point-free style. For example, this is hard to read: 360 | 361 | ```haskell 362 | -- Bad: 363 | f = (g .) . h 364 | ``` 365 | 366 | ### Warnings ### 367 | 368 | Code should be compilable with `-Wall -Werror`. There should be no 369 | warnings. 370 | -------------------------------------------------------------------------------- /app/Args.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | module Args 4 | ( module Args 5 | , runApp 6 | ) where 7 | 8 | import Data.Maybe 9 | import Data.List 10 | import Control.Monad 11 | import Control.Applicative 12 | 13 | import System.Directory 14 | import System.Console.ArgParser 15 | import System.Console.ArgParser.QuickParams 16 | 17 | import Fuzzers 18 | 19 | inputToken = "@@" 20 | 21 | -- |Required to read Maybe parameters 22 | instance RawRead a => RawRead (Maybe a) where 23 | rawParse s = do 24 | (val, rem) <- rawParse s 25 | return (Just val, rem) 26 | 27 | -- |Required to read Fuzzer parameter 28 | instance RawRead Fuzzer where 29 | rawParse (stripPrefix "zzuf" -> Just rem) = Just (Zzuf, rem) 30 | rawParse (stripPrefix "radamsa" -> Just rem) = Just (Radamsa, rem) 31 | rawParse _ = Nothing 32 | 33 | -- |The data type representing the actions 34 | -- that QuickFuzz can perform 35 | data QFCommand 36 | = GenTest -- ^Generate, maybe fuzz, execute and maybe shrink 37 | { format :: String 38 | , cli :: String 39 | , verbose :: Bool 40 | , timeout :: Maybe Int 41 | , shrinking :: Bool 42 | , fuzzer :: Maybe Fuzzer 43 | , singleFail :: Bool 44 | , genSeed :: Maybe Int 45 | , maxTries :: Maybe Int 46 | , minSize :: Int 47 | , maxSize :: Int 48 | , outDir :: String 49 | , outFile :: Maybe String } 50 | | MutTest -- ^Read, mutate, execute and maybe shrink 51 | { format :: String 52 | , cli :: String 53 | , inDir :: String 54 | , verbose :: Bool 55 | , timeout :: Maybe Int 56 | , shrinking :: Bool 57 | , singleFail :: Bool 58 | , genSeed :: Maybe Int 59 | , maxTries :: Maybe Int 60 | , minSize :: Int 61 | , maxSize :: Int 62 | , outDir :: String 63 | , outFile :: Maybe String } 64 | | Gen -- ^Generate some test cases 65 | { format :: String 66 | , genSeed :: Maybe Int 67 | , minSize :: Int 68 | , maxSize :: Int 69 | , genQty :: Int 70 | , outDir :: String } 71 | | Serve -- ^Serve some data using a socket 72 | { format :: String 73 | , port :: Int 74 | , minSize :: Int 75 | , maxSize :: Int 76 | , genQty :: Int 77 | , outDir :: String } 78 | | Exec -- ^Execute command using a given data set, maybe shrikning 79 | { format :: String 80 | , cli :: String 81 | , verbose :: Bool 82 | , timeout :: Maybe Int 83 | , shrinking :: Bool 84 | , fuzzer :: Maybe Fuzzer 85 | , singleFail :: Bool 86 | , inDir :: String 87 | , outDir :: String 88 | , outFile :: Maybe String } 89 | | Shrink -- ^Shrink a given set of test cases 90 | { format :: String 91 | , cli :: String 92 | , verbose :: Bool 93 | , timeout :: Maybe Int 94 | , inDir :: String 95 | , outDir :: String 96 | , outFile :: Maybe String } 97 | | List -- ^List supported data types 98 | deriving Show 99 | 100 | 101 | -- | Main parsing function 102 | parseCommand :: IO (CmdLnInterface QFCommand) 103 | parseCommand = setVersion "1.0.0" 104 | <$> setDescr "An experimental grammar fuzzer in Haskell using QuickCheck." 105 | <$> setEpilog "More info: QuickFuzz.org" 106 | <$> parseSubcommand 107 | 108 | -- | Compose main parser using subcommand parsers 109 | parseSubcommand :: IO (CmdLnInterface QFCommand) 110 | parseSubcommand = mkSubParser 111 | [ ("gentest", mkDefaultApp gentestParser "gentest") 112 | , ("muttest", mkDefaultApp muttestParser "muttest") 113 | , ("gen", mkDefaultApp genParser "gen") 114 | , ("serve", mkDefaultApp serveParser "serve") 115 | , ("exec", mkDefaultApp execParser "exec") 116 | , ("reduce", mkDefaultApp shrinkParser "reduce") 117 | , ("list", mkDefaultApp listParser "list") ] 118 | 119 | -- | GenTest subcommand parser 120 | gentestParser :: ParserSpec QFCommand 121 | gentestParser = GenTest 122 | `parsedBy` reqPos "format" `Descr` "File format to generate (run list option to see available formats)" 123 | `andBy` reqPos "command" `Descr` "Command line to execute" 124 | `andBy` boolFlag "verbose" `Descr` "Print execution output" 125 | `andBy` optFlag Nothing "timeout" `Descr` "Set a timeout to prevent long executions" 126 | `andBy` boolFlag "reduce" `Descr` "Reduce crash-inducing test cases" 127 | `andBy` optFlag Nothing "fuzzer" `Descr` "Set a fuzzer to mutate generated test cases before execution" 128 | `andBy` boolFlag "keep" `Descr` "Keep testing after finding a crashing test case" 129 | `andBy` optFlag Nothing "seed" `Descr` "Generate using a given integer seed" 130 | `andBy` optFlag Nothing "quantity" `Descr` "Maximum number of tries" 131 | `andBy` optFlag 1 "lower" `Descr` "Minimum generation size" 132 | `andBy` optFlag 50 "upper" `Descr` "Maximum generation size" 133 | `andBy` optFlag "outdir" "outdir" `Descr` "Output directory" 134 | `andBy` optFlag Nothing "name" `Descr` "Output filename" 135 | 136 | -- | Test subcommand parser 137 | muttestParser :: ParserSpec QFCommand 138 | muttestParser = MutTest 139 | `parsedBy` reqPos "format" `Descr` "File format to mutate (run list option to see available formats)" 140 | `andBy` reqPos "command" `Descr` "Command line to execute" 141 | `andBy` reqPos "indir" `Descr` "Directory with inputs to mutate" 142 | `andBy` boolFlag "verbose" `Descr` "Print execution output" 143 | `andBy` optFlag Nothing "timeout" `Descr` "Set a timeout to prevent long executions" 144 | `andBy` boolFlag "reduce" `Descr` "Reduce crash-inducing test cases" 145 | `andBy` boolFlag "keep" `Descr` "Keep testing after finding a crashing test case" 146 | `andBy` optFlag Nothing "seed" `Descr` "Generate using a given integer seed" 147 | `andBy` optFlag Nothing "quantity" `Descr` "Maximum number of tries" 148 | `andBy` optFlag 1 "lower" `Descr` "Minimum generation size" 149 | `andBy` optFlag 50 "upper" `Descr` "Maximum generation size" 150 | `andBy` optFlag "outdir" "outdir" `Descr` "Output directory" 151 | `andBy` optFlag Nothing "name" `Descr` "Output filename" 152 | 153 | 154 | -- | Gen subcommand parser 155 | genParser :: ParserSpec QFCommand 156 | genParser = Gen 157 | `parsedBy` reqPos "format" `Descr` "File format to generate (run list option to see available formats)" 158 | `andBy` optFlag Nothing "seed" `Descr` "Generate using a given integer seed" 159 | `andBy` optFlag 1 "lower" `Descr` "Minimum generation size" 160 | `andBy` optFlag 50 "upper" `Descr` "Maximum generation size" 161 | `andBy` optFlag 1000 "quantity" `Descr` "Number of generated files" 162 | `andBy` optFlag "outdir" "outdir" `Descr` "Output directory" 163 | 164 | 165 | -- | Serve subcommand parser 166 | serveParser :: ParserSpec QFCommand 167 | serveParser = Serve 168 | `parsedBy` reqPos "format" `Descr` "File format to generate (run list option to see available formats)" 169 | `andBy` reqPos "port" `Descr` "Port number to bind" 170 | `andBy` optFlag 1 "lower" `Descr` "Minimum generation size" 171 | `andBy` optFlag 50 "upper" `Descr` "Maximum generation size" 172 | `andBy` optFlag 1000 "quantity" `Descr` "Number of generated files" 173 | `andBy` optFlag "outdir" "outdir" `Descr` "Output directory" 174 | 175 | 176 | -- | Exec subcommand parser 177 | execParser :: ParserSpec QFCommand 178 | execParser = Exec 179 | `parsedBy` reqPos "format" `Descr` "File format to execute (run list option to see available formats)" 180 | `andBy` reqPos "command" `Descr` "Command line to execute" 181 | `andBy` boolFlag "verbose" `Descr` "Print execution output" 182 | `andBy` optFlag Nothing "timeout" `Descr` "Set a timeout to prevent long executions" 183 | `andBy` boolFlag "reduce" `Descr` "Reduce crash-inducing test cases" 184 | `andBy` optFlag Nothing "fuzzer" `Descr` "Set a fuzzer to mutate generated test cases before execution" 185 | `andBy` boolFlag "keep" `Descr` "Keep testing after finding a crashing test case" 186 | `andBy` optFlag "indir" "inputs" `Descr` "Path to inputs test cases" 187 | `andBy` optFlag "outdir" "outdir" `Descr` "Output directory" 188 | `andBy` optFlag Nothing "name" `Descr` "Output filename" 189 | 190 | -- | Shrink subcommand parser 191 | shrinkParser :: ParserSpec QFCommand 192 | shrinkParser = Shrink 193 | `parsedBy` reqPos "format" `Descr` "File format to generate (run list option to see available formats)" 194 | `andBy` reqPos "command" `Descr` "Command line to execute" 195 | `andBy` boolFlag "verbose" `Descr` "Print execution output" 196 | `andBy` optFlag Nothing "timeout" `Descr` "Set a timeout to prevent long executions" 197 | `andBy` optFlag "indir" "inputs" `Descr` "Path to inputs test cases" 198 | `andBy` optFlag "outdir" "outdir" `Descr` "Output directory" 199 | `andBy` optFlag Nothing "name" `Descr` "Output filename" 200 | 201 | -- | List subcommand parser 202 | listParser = pure List 203 | 204 | -- |Command attributes shortcuts 205 | usesFile :: QFCommand -> Bool 206 | usesFile = isInfixOf inputToken . cli 207 | 208 | usesTimeout :: QFCommand -> Bool 209 | usesTimeout = isJust . timeout 210 | 211 | usesFuzzer :: QFCommand -> Bool 212 | usesFuzzer = isJust . fuzzer 213 | 214 | usesTriesLimit :: QFCommand -> Bool 215 | usesTriesLimit = isJust . maxTries 216 | 217 | usesOutFile :: QFCommand -> Bool 218 | usesOutFile = isJust . outFile 219 | 220 | usesSeed :: QFCommand -> Bool 221 | usesSeed = isJust . genSeed 222 | 223 | -- |Args sanitizing, e.g: check lower/upper bounds, 224 | -- check executable existense, etc. 225 | sanitize :: QFCommand -> IO QFCommand 226 | sanitize cmd@(GenTest {}) = checkBounds cmd >>= checkSeedTries >>= checkMaxTries 227 | sanitize cmd@(MutTest {}) = checkBounds cmd >>= checkSeedTries >>= checkMaxTries 228 | sanitize cmd@(Gen {}) = checkGenQty cmd >>= checkBounds >>= checkSeedQty 229 | sanitize cmd@(Exec {}) = checkInDir cmd 230 | sanitize cmd@(Shrink {}) = checkInDir cmd 231 | sanitize cmd@(Serve {}) = checkGenQty cmd >>= checkBounds 232 | sanitize List = return List 233 | 234 | checkGenQty :: QFCommand -> IO QFCommand 235 | checkGenQty cmd = do 236 | when (genQty cmd < 1) (error "Generation quantity must be positive") 237 | return cmd 238 | 239 | checkMaxTries :: QFCommand -> IO QFCommand 240 | checkMaxTries cmd@(maxTries -> Nothing) = return cmd 241 | checkMaxTries cmd@(maxTries -> Just tries) = do 242 | when (tries < 1) (error "Maximum number of tries must be positive") 243 | return cmd 244 | 245 | checkSeedTries :: QFCommand -> IO QFCommand 246 | checkSeedTries cmd@(genSeed -> Nothing) = return cmd 247 | checkSeedTries cmd@(genSeed -> Just seed) = do 248 | when (seed < 0) (error "Seed must be non-negative") 249 | return $ cmd {maxTries = Just 1} 250 | 251 | checkSeedQty :: QFCommand -> IO QFCommand 252 | checkSeedQty cmd@(genSeed -> Nothing) = return cmd 253 | checkSeedQty cmd@(genSeed -> Just seed) = do 254 | when (seed < 0) (error "Seed must be non-negative") 255 | return $ cmd {genQty = 1} 256 | 257 | checkInDir :: QFCommand -> IO QFCommand 258 | checkInDir cmd = do 259 | inDirExist <- doesDirectoryExist (inDir cmd) 260 | when (not inDirExist) (error "Input directory does not exist") 261 | return cmd 262 | 263 | checkBounds :: QFCommand -> IO QFCommand 264 | checkBounds cmd = do 265 | when (minSize cmd <= 0) (error "Minimum generation size must be positive") 266 | when (maxSize cmd <= 0) (error "Maximum generation size must be positive") 267 | let [sMin, sMax] = sort [minSize cmd, maxSize cmd] 268 | return $ cmd {minSize = sMin, maxSize = sMax} 269 | 270 | checkExe :: QFCommand -> IO QFCommand 271 | checkExe cmd = do 272 | let name = head (words (cli cmd)) 273 | exe <- findExecutable name 274 | when (isNothing exe) (error $ "Executable " ++ name ++ " not found. ") 275 | return cmd 276 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/Fixable.hs: -------------------------------------------------------------------------------- 1 | {-# Language TemplateHaskell, ConstraintKinds, FlexibleInstances, FlexibleContexts, IncoherentInstances, MultiParamTypeClasses #-} 2 | {-# Language CPP #-} 3 | module Test.QuickFuzz.Derive.Fixable where 4 | 5 | 6 | import Data.List 7 | 8 | import Test.QuickCheck 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Control.Monad.Trans 12 | import Control.Monad.Trans.State 13 | import Language.Haskell.TH 14 | import Language.Haskell.TH.Syntax 15 | 16 | -- import Debug.Trace 17 | import Megadeth.Prim 18 | 19 | #if MIN_VERSION_template_haskell(2,11,0) 20 | # define TH211MBKIND _maybe_kind 21 | #else 22 | # define TH211MBKIND 23 | #endif 24 | 25 | -- |The state is composed of identifiers. 26 | data StV a = StV {vars :: [a]} deriving Show 27 | 28 | type VState a b = StateT (StV a) Gen b 29 | 30 | -- |Fixable class 31 | class Fixable a b where 32 | fix :: b -> VState a b 33 | 34 | -- Common instances 35 | instance Fixable a b => Fixable a [b] where 36 | fix = mapM fix 37 | 38 | instance Fixable a b => Fixable a (Maybe b) where 39 | fix (Nothing) = return Nothing 40 | fix (Just a) = do ca <- fix a 41 | return $ Just ca 42 | 43 | instance (Fixable a b, Fixable a c) => Fixable a (b,c) where 44 | fix (x,y) = do cx <- fix x 45 | cy <- fix y 46 | return (cx, cy) 47 | 48 | instance Fixable a Char where 49 | fix = return 50 | 51 | instance Fixable a Double where 52 | fix = return 53 | 54 | instance Fixable a Bool where 55 | fix = return 56 | 57 | instance Fixable a Integer where 58 | fix = return 59 | 60 | instance Fixable a Int where 61 | fix = return 62 | 63 | instance Fixable a a where 64 | fix = return 65 | 66 | -- |Extract name and number of arguments from a constructor 67 | 68 | getStuff :: Con -> (Name, Int) 69 | getStuff (NormalC n xs) = (n, length xs) 70 | getStuff (RecC n xs) = (n, length xs) 71 | getStuff _ = error "wrong constructor" 72 | 73 | -- |Extract name from some type variable 74 | 75 | getParName :: TyVarBndr -> Name 76 | getParName (PlainTV n) = n 77 | getParName (KindedTV n _) = n 78 | 79 | -- |Takes some constructor and checks if it's either an assign or a variable. If that's the case then it makes the appropiate match; 80 | -- if not, it creates a trivial match to fix recursively. 81 | 82 | mkMatch :: [Name] -> [Name] -> (Name, Int) -> Q Match 83 | mkMatch v a (n, m) = let stName = mkName "st" 84 | idName = mkName "vid" 85 | vp = mkName "vp" 86 | getvid = mkName "getVId" 87 | getName = mkName "get" 88 | printStN = mkName "printSt" 89 | vars = mkName "vars" 90 | liftName = mkName "lift" 91 | gencons = mkName "genCons" 92 | genvar = mkName "genVar" 93 | rName = mkName "return" 94 | pushName = mkName "pushId" 95 | ap = mkName "ap" 96 | getaid = mkName "getAId" in 97 | if elem n v then --Variable 98 | do xlist <- replicateM m (newName "x") 99 | let pats = map varP xlist 100 | --Extract id, check if it's in the state. If it's not, replace it with one from 101 | --the state, or if the state is empty, put some other expression (maybe a constant) 102 | b <- [| let $(varP idName) = $(appE (varE getvid) (varE vp)) in 103 | do $(varP stName) <- $(varE getName) 104 | --traceM $ $(varE printStN) $(varE stName) --uncomment this line for debugging 105 | case elem $(varE idName) ($(appE (varE vars) (varE stName))) of 106 | True -> return $(varE vp) 107 | False -> if null (($(appE (varE vars) (varE stName)))) then 108 | do c <- $(varE liftName) $ $(varE gencons) 109 | return c 110 | else do newv <- $(varE liftName) $ ($(appE (varE genvar) (appE (varE vars) (varE stName)))) 111 | return newv |] 112 | match (asP vp (conP n pats)) (normalB (returnQ b)) [] 113 | else if elem n a then --Assign 114 | do xlist <- replicateM m (newName "x") 115 | let pats = map varP xlist 116 | --Extract id, check if it's in the state. If it's not, add it. 117 | cpairs <- mapM mkDoB (tail xlist) 118 | let (cohs, binds) = (map fst cpairs, map snd cpairs) 119 | let xvars = map VarE ((head xlist):cohs) 120 | let retBind = NoBindS (AppE (VarE rName) (foldl AppE (ConE n) xvars)) 121 | let doBodyT = return $ DoE (binds++[retBind]) 122 | let pushBind = NoBindS (AppE (VarE pushName) (VarE idName)) --push id to the state 123 | let doBodyF = return $ DoE (binds++[pushBind,retBind]) 124 | b <- [| let $(varP idName) = $(appE (varE getaid) (varE ap)) in 125 | do $(varP stName) <- $(varE getName) 126 | --traceM $ $(varE printStN) $(varE stName) --uncomment this line for debugging 127 | case elem $(varE idName) ($(appE (varE vars) (varE stName))) of 128 | True -> $(doBodyT) 129 | False -> $(doBodyF) |] 130 | match (asP ap (conP n pats)) (normalB (returnQ b)) [] 131 | else --Other constructors 132 | do xlist <- replicateM m (newName "x") 133 | let pats = map varP xlist 134 | --Just do a fix of the constructor arguments and return the fixed constructor 135 | cpairs <- mapM mkDoB xlist 136 | let (cohs, binds) = (map fst cpairs, map snd cpairs) 137 | let xvars = map VarE cohs 138 | let retBind = NoBindS (AppE (VarE rName) (foldl AppE (ConE n) xvars)) 139 | let doBody = DoE (binds++[retBind]) 140 | match (conP n pats) (normalB (returnQ doBody)) [] 141 | 142 | -- |Generates an expression of the form cx <- fix x 143 | 144 | mkDoB :: Name -> Q (Name, Stmt) 145 | mkDoB x = do cx <- newName "cx" 146 | let fixN = mkName "fix" 147 | return $ (cx, BindS (VarP cx) (AppE (VarE fixN) (VarE x))) 148 | 149 | -- |Given a list of matches (built with mkMatch), generate a function body. 150 | 151 | mkFixBody :: [Q Match] -> Q Exp 152 | mkFixBody matches = let e = mkName "e" in 153 | lamE [varP e] (caseE (varE e) matches) 154 | 155 | -- |Uses Megadeth to make every Fixable instance needed 156 | 157 | devFixLang :: Name -> [Name] -> [Name] -> Name -> Q [Dec] 158 | devFixLang i v ka t = prevDev t (const $ return False) >>= mapM (mkFix i v ka) >>= (return . concat) 159 | 160 | -- |Creates a Fixable instance for a type, needs information to know which constructors represent 161 | -- the identifiers, variables and assignments 162 | 163 | mkFix :: Name -> [Name] -> [Name] -> Name -> Q [Dec] 164 | mkFix i v a t = do ti <- reify t 165 | case ti of 166 | TyConI (DataD _ _ params TH211MBKIND tcons _) -> do 167 | let cstuff = map getStuff tcons 168 | let names = map fst cstuff 169 | let matches = map (mkMatch v a) cstuff 170 | let np = length params 171 | let tvars = map (varT . getParName) params 172 | ii <- reify i 173 | case ii of 174 | TyConI (DataD _ _ ip TH211MBKIND _ _) -> do 175 | let ivars = map (varT . getParName) ip 176 | let nip = max np (length ip) 177 | plist <- replicateM nip (newName "x") 178 | let pvars = map varT plist 179 | if null tvars then 180 | if null ivars then [d| instance Fixable $(conT i) $(conT t) where 181 | fix = gg where 182 | gg :: $(conT t) -> VState $(conT i) $(conT t) 183 | gg = $(mkFixBody matches) |] 184 | else [d| instance Fixable $(foldl appT (conT i) pvars) $(conT t) where 185 | fix = gg where 186 | gg :: $(conT t) -> VState $(foldl appT (conT i) pvars) $(conT t) 187 | gg = $(mkFixBody matches) |] 188 | else 189 | if null ivars then [d| instance $(foldl appT (tupleT (3*nip)) ((map (appT (conT ''Arbitrary)) pvars)++(map (appT (conT ''Eq)) pvars) ++(map (appT (conT ''Show)) pvars))) 190 | => Fixable $(conT i) $(foldl appT (conT t) pvars) where 191 | fix = gg where 192 | gg :: $(foldl appT (conT t) pvars) -> VState $(conT i) $(foldl appT (conT t) pvars) 193 | gg = $(mkFixBody matches) |] 194 | else [d| instance $(foldl appT (tupleT (3*nip)) ((map (appT (conT ''Arbitrary)) pvars)++(map (appT (conT ''Eq)) pvars)++(map (appT (conT ''Show)) pvars))) 195 | => Fixable $(foldl appT (conT i) pvars) $(foldl appT (conT t) pvars) where 196 | fix = gg where 197 | gg :: $(foldl appT (conT t) pvars) -> VState $(foldl appT (conT i) pvars) $(foldl appT (conT t) pvars) 198 | gg = $(mkFixBody matches) |] 199 | TyConI (NewtypeD _ _ ip TH211MBKIND _ _) -> do 200 | let ivars = map (varT . getParName) ip 201 | let nip = max np (length ip) 202 | plist <- replicateM nip (newName "x") 203 | let pvars = map varT plist 204 | if null tvars then 205 | if null ivars then [d| instance Fixable $(conT i) $(conT t) where 206 | fix = gg where 207 | gg :: $(conT t) -> VState $(conT i) $(conT t) 208 | gg = $(mkFixBody matches) |] 209 | else [d| instance Fixable $(foldl appT (conT i) pvars) $(conT t) where 210 | fix = gg where 211 | gg :: $(conT t) -> VState $(foldl appT (conT i) pvars) $(conT t) 212 | gg = $(mkFixBody matches) |] 213 | else 214 | if null ivars then [d| instance $(foldl appT (tupleT (3*nip)) ((map (appT (conT ''Arbitrary)) pvars)++(map (appT (conT ''Eq)) pvars)++(map (appT (conT ''Show)) pvars))) 215 | => Fixable $(conT i) $(foldl appT (conT t) pvars) where 216 | fix = gg where 217 | gg :: $(foldl appT (conT t) pvars) -> VState $(conT i) $(foldl appT (conT t) pvars) 218 | gg = $(mkFixBody matches) |] 219 | else [d| instance $(foldl appT (tupleT (3*nip)) ((map (appT (conT ''Arbitrary)) pvars)++(map (appT (conT ''Eq)) pvars)++(map (appT (conT ''Show)) pvars))) 220 | => Fixable $(foldl appT (conT i) pvars) $(foldl appT (conT t) pvars) where 221 | fix = gg where 222 | gg :: $(foldl appT (conT t) pvars) -> VState $(foldl appT (conT i) pvars) $(foldl appT (conT t) pvars) 223 | gg = $(mkFixBody matches) |] 224 | TyConI (TySynD _ ip _) -> do 225 | let ivars = map (varT . getParName) ip 226 | let nip = max np (length ip) 227 | plist <- replicateM nip (newName "x") 228 | let pvars = map varT plist 229 | if null tvars then 230 | if null ivars then [d| instance Fixable $(conT i) $(conT t) where 231 | fix = gg where 232 | gg :: $(conT t) -> VState $(conT i) $(conT t) 233 | gg = $(mkFixBody matches) |] 234 | else [d| instance Fixable $(foldl appT (conT i) pvars) $(conT t) where 235 | fix = gg where 236 | gg :: $(conT t) -> VState $(foldl appT (conT i) pvars) $(conT t) 237 | gg = $(mkFixBody matches) |] 238 | else 239 | if null ivars then [d| instance $(foldl appT (tupleT (3*nip)) ((map (appT (conT ''Arbitrary)) pvars)++(map (appT (conT ''Eq)) pvars)++(map (appT (conT ''Show)) pvars))) 240 | => Fixable $(conT i) $(foldl appT (conT t) pvars) where 241 | fix = gg where 242 | gg :: $(foldl appT (conT t) pvars) -> VState $(conT i) $(foldl appT (conT t) pvars) 243 | gg = $(mkFixBody matches) |] 244 | else [d| instance $(foldl appT (tupleT (3*nip)) ((map (appT (conT ''Arbitrary)) pvars)++(map (appT (conT ''Eq)) pvars)++(map (appT (conT ''Show)) pvars))) 245 | => Fixable $(foldl appT (conT i) pvars) $(foldl appT (conT t) pvars) where 246 | fix = gg where 247 | gg :: $(foldl appT (conT t) pvars) -> VState $(foldl appT (conT i) pvars) $(foldl appT (conT t) pvars) 248 | gg = $(mkFixBody matches) |] 249 | --newtype case? 250 | _ -> return [] 251 | 252 | -------------------------------------------------------------------------------- /src/Test/QuickFuzz/Derive/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE CPP #-} 5 | module Test.QuickFuzz.Derive.Arbitrary ( 6 | devArbitrary 7 | ) where 8 | 9 | import Megadeth.Prim 10 | import Test.QuickFuzz.Global 11 | 12 | 13 | import Data.List.Split 14 | import Data.Maybe 15 | -- Gen 16 | import Language.Haskell.TH 17 | import Language.Haskell.TH.Syntax as TH 18 | import Test.QuickCheck 19 | import GHC.Exts 20 | import GHC.Types 21 | -- Normal Arbitrary 22 | -- 23 | import Control.Monad 24 | import Control.Arrow 25 | import Control.Applicative 26 | import Data.List 27 | 28 | #if MIN_VERSION_template_haskell(2,11,0) 29 | # define TH211MBKIND _maybe_kind 30 | #else 31 | # define TH211MBKIND 32 | #endif 33 | 34 | -- | Build the arbitrary function with makeArbs 35 | chooseExpQ :: Name -> Name -> Name -> Integer -> TH.Type -> ExpQ 36 | chooseExpQ g n t bf (AppT ListT ty) = [| vectorOf ($(varE n) `min` 10) $ resize ($(varE n) `div` 10) arbitrary |] 37 | chooseExpQ g n t bf ty | headOf ty /= t = [| resize (max 0 ($(varE n) - 1)) arbitrary |] 38 | chooseExpQ g n t bf ty = 39 | case bf of 40 | 0 -> [| arbitrary |] 41 | 1 -> [| $(varE g) $ $(varE n) - 1 |] 42 | bf -> [| $(varE g) $ $(varE n) `div` bf |] 43 | 44 | 45 | makeArbs :: Name -> Name -> Name -> [ConView] -> [ExpQ] 46 | makeArbs g n t xs = 47 | map (fmap fixAppl) 48 | [ 49 | foldl 50 | (\h ty -> uInfixE h (varE '(<*>)) (chooseExpQ g n t bf ty)) 51 | (conE name) tys' 52 | | SimpleCon name bf tys' <- xs] 53 | 54 | oneOfStr :: Name -> Name -> Name -> [ConView] -> ExpQ 55 | oneOfStr g n t xs = 56 | [| oneof $(listE (makeArbs g n t xs)) |] 57 | 58 | simfreqStr :: Name -> Name -> Name -> [ConView] -> ExpQ 59 | simfreqStr g n t xs = 60 | [| frequency $ zip (getFreqs name) $(listE (makeArbs g n t xs)) |] 61 | where name = "sim"++(show t) 62 | 63 | reqfreqStr :: Name -> Name -> Name -> [ConView] -> ExpQ 64 | reqfreqStr g n t xs = 65 | [| frequency $ zip (getFreqs name) $(listE (makeArbs g n t xs)) |] 66 | where name = "req"++(show t) 67 | 68 | 69 | 70 | -- | Generic function used to create arbitrarily large tuples 71 | -- @ 72 | -- do 73 | -- a1 <- arbitrary 74 | -- a2 <- arbitrary 75 | -- .... 76 | -- return $ (a1,a2,...) 77 | -- @ 78 | genTupleArbs :: Int -> ExpQ 79 | genTupleArbs n = 80 | let ys = take n varNames 81 | xs = map mkName ys 82 | in 83 | doE $ 84 | map (\x -> bindS (varP x) (varE 'arbitrary)) xs 85 | ++ [ noBindS $ appE (varE 'return) (tupE (map varE xs))] 86 | -- | Custom Gen simpleView 87 | cstmSimpleV :: ConView -> (Name -> Name) -> ExpQ 88 | cstmSimpleV (SimpleCon n _ []) cstI = conE n -- varE $ cstI n 89 | cstmSimpleV (SimpleCon n _ as) cstI = foldl (\ r t -> 90 | case t of 91 | (ConT n') -> uInfixE r (varE '(<*>)) (varE $ cstI n') 92 | _ -> error "Not sure yet" 93 | ) (conE n) as 94 | 95 | 96 | -- | Custom generators 97 | deriveGenerator :: Name -> (Name -> Name) -> Q Dec 98 | deriveGenerator t cstMap = do 99 | inf <- reify t 100 | --runIO $ print $ "Generating custom dev for " ++ show inf 101 | case inf of 102 | TyConI (DataD _ _ params TH211MBKIND constructors _ ) -> 103 | let fnm = mkName $ "cstm_" ++ (showName t) 104 | scons = map (simpleConView t) constructors 105 | fcs = filter ((== 0) . bf) scons 106 | n = mkName "n" 107 | in funD fnm $ [(clause [litP $ integerL 0] 108 | ( normalB $ [| oneof $(listE (map (\ x -> cstmSimpleV x (\ _ -> 'arbitrary) ) fcs) ) |] 109 | ) []) 110 | , (clause [varP n] (normalB 111 | $ [| oneof $(listE (map (flip cstmSimpleV cstMap) scons) ) |] ) 112 | []) 113 | ] 114 | 115 | 116 | countConstructors (TyConI (DataD _ _ _ TH211MBKIND constructors _ )) = length constructors 117 | countConstructors _ = 1 118 | -- | Give an arbitrary instance for its argument. 119 | -- It doesn't check anything, just assume that it is ok to instance 120 | -- its argument. And define the function arbitrary depending what type its 121 | -- argument references to. 122 | deriveArbitrary :: Name -> Q [Dec] 123 | deriveArbitrary t = do 124 | inf <- reify t 125 | runIO $ print $ "('" ++ show t ++ "' , " ++ show (countConstructors inf) ++ ")" 126 | case inf of 127 | TyConI (DataD _ _ params TH211MBKIND constructors _) -> do 128 | let ns = map varT $ paramNames params 129 | scons = map (simpleConView t) constructors 130 | fcs = filter ((==0) . bf) scons 131 | gos g n = -- Fancy gos 132 | if length scons > 1 133 | then 134 | if length fcs == length scons 135 | then 136 | reqfreqStr g n t fcs 137 | else 138 | if length fcs > 1 139 | then 140 | [| if $(varE n) <= 1 141 | then $(simfreqStr g n t fcs) 142 | else $(reqfreqStr g n t scons)|] 143 | else 144 | [| if $(varE n) <= 1 145 | then $(head (makeArbs g n t fcs)) 146 | else $(reqfreqStr g n t scons)|] 147 | else 148 | [| $(head (makeArbs g n t scons)) |] 149 | if not $ null ns then 150 | [d| instance $(applyTo (tupleT (length ns)) (map (appT (conT ''Arbitrary)) ns)) 151 | => Arbitrary $(applyTo (conT t) ns) where 152 | arbitrary = sized go 153 | where go n = $(gos 'go 'n) |] 154 | else 155 | [d| instance Arbitrary $(applyTo (conT t) ns) where 156 | arbitrary = sized go 157 | where go n = $(gos 'go 'n)|] 158 | TyConI (NewtypeD _ _ params TH211MBKIND con _) -> do 159 | let ns = map varT $ paramNames params 160 | scon = simpleConView t con 161 | if not $ null ns then 162 | [d| instance $(applyTo (tupleT (length ns)) (map (appT (conT ''Arbitrary)) ns)) 163 | => Arbitrary $(applyTo (conT t) ns) where 164 | arbitrary = sized go 165 | where go n = $(head (makeArbs 'go 'n t [scon])) |] 166 | else 167 | [d| instance Arbitrary $(applyTo (conT t) ns) where 168 | arbitrary = sized go 169 | where go n = $(head (makeArbs 'go 'n t [scon])) |] 170 | TyConI inp@(TySynD _ params ty) -> 171 | case (getTy ty) of 172 | (TupleT n) -> 173 | let ns = map varT $ paramNames params in 174 | if not $ null ns then 175 | [d| instance $(applyTo (tupleT (length ns)) (map (appT (conT ''Arbitrary)) ns)) 176 | => Arbitrary $(applyTo (conT t) ns) where 177 | arbitrary = $(genTupleArbs n) |] 178 | else 179 | [d| instance Arbitrary $(applyTo (conT t) ns) where 180 | arbitrary = $(genTupleArbs n) |] 181 | (ConT n) -> return [] -- This type should had been derived already, 182 | -- It is clearly a dependency and it 183 | -- should be put before in the topsort. 184 | _ -> do 185 | runIO $ print "IGNORING" 186 | runIO $ print ty 187 | return [] 188 | d -> do 189 | if (isPrim inf) then return [] else 190 | (fail $ "Case not defined: " ++ show d) 191 | 192 | isArbInsName = isinsName ''Arbitrary 193 | 194 | devArbitrary :: Name -> Q [Dec] 195 | devArbitrary = megaderive deriveArbitrary isArbInsName 196 | 197 | -- devDeriveArbitrary :: Name -> Q [Dec] 198 | -- devDeriveArbitrary = megaderive (derive makeArbitrary) isArbInsName 199 | 200 | {- 201 | -- Gen 202 | -- 203 | --- 204 | 205 | as :: [Name] 206 | as = map (\x -> mkName $ 'a':show x) ([1..] :: [Int]) 207 | 208 | customFun :: Name -> [(Name,[Maybe Bool])] -> Q Dec -- Can I give the type too? 209 | customFun fname cons = do 210 | let lis = mkName "xs" 211 | let n = mkName "n" 212 | let newl = mkName "newl" 213 | let dropold = appE (appE (varE 'drop) (lift $ length cons)) (varE lis) 214 | let nmu = (appE (appE (varE '(-)) (varE n)) ([|1|])) 215 | let sizedarb = appE (appE (varE 'resize) (varE n)) $ varE 'arbitrary 216 | let listaFreq' nmuu = listE $ reverse $ foldl 217 | (\res (c,bs) -> 218 | (foldl 219 | (\r b -> appE (appE (varE '(<*>)) r) 220 | (case b of 221 | Nothing -> sizedarb 222 | Just True -> appE (appE (varE fname) (varE lis)) nmuu 223 | _ -> appE (appE (varE fname) dropold) nmuu 224 | )) (appE (varE 'pure) (conE c)) bs) : res) 225 | [] cons 226 | {- 227 | let listaFreq'' = appE (appE (varE 'zip) (varE lis)) $ listE $ reverse $ foldl 228 | (\res (c,bs) -> 229 | if null bs then 230 | [|return $(conE c)|] : res 231 | else res) [] cons 232 | -} 233 | {- 234 | let listaFreq'' = listE $ reverse $ foldl 235 | (\res (c,bs) -> 236 | if (and $ map isJust bs) 237 | then res else 238 | (foldl (\r x -> [|$(r) <*> arbitrary |]) (appE (varE 'pure) (conE c)) bs) : res) 239 | [] cons 240 | -} 241 | let listaFreq = appE (appE (varE 'zip) (varE lis)) (listaFreq' nmu) 242 | funD fname $ 243 | [ clause [varP lis, [p|0|]] (normalB $ [|resize 0 arbitrary|]) [] 244 | , clause [varP lis,varP n] 245 | (normalB $ 246 | appE (varE 'frequency) 247 | listaFreq 248 | ) 249 | [] 250 | ] 251 | 252 | customFunNewT :: Name -> (Name,[Maybe Bool]) -> Q Dec 253 | customFunNewT fname (cnm, mbs) = do 254 | let lis = mkName "xs" 255 | let n = mkName "n" 256 | funD fname $ [ 257 | clause [varP lis, [p|0|]] (normalB $ [|resize 0 arbitrary|]) [] 258 | ,clause [varP lis, varP n] (normalB $ 259 | foldl (\res mb -> 260 | infixE 261 | (Just res) 262 | (varE '(<*>)) 263 | $ Just $ case mb of 264 | Nothing -> [|resize $(varE n) arbitrary|] 265 | Just _ -> appE (appE (varE fname) (varE lis)) (varE n) 266 | ) (appE (varE 'pure) (conE cnm)) mbs 267 | ) [] 268 | ] 269 | 270 | customTup :: Name -> Name -> Int -> Q Exp 271 | customTup xs n mbs = 272 | let reccall = appE (appE (varE 'prob_gen) (varE xs)) (varE n) 273 | in 274 | foldl (\r _ -> 275 | infixE (Just r) (varE '(<*>)) $ 276 | Just $ reccall) (appE (varE 'pure) (conE (tupleDataName mbs))) $ replicate mbs 1 277 | 278 | compCust :: Dec -> Q Dec 279 | compCust (FunD n _) = 280 | let nm = mkName $ "sized_" ++ (showName n) 281 | s = mkName "s" 282 | in 283 | funD nm [clause [varP s] (normalB $ appE (varE ('sized)) (appE (varE n) (varE s))) []] 284 | 285 | prefixT :: Name -> String 286 | prefixT n = let spt = splitOn "." $ show n 287 | in concat $ init spt 288 | 289 | prepareArgCons (prefname,name) = map (\ty -> case ty of 290 | ConT n' -> 291 | let pren' = prefixT n' 292 | in 293 | if (n' == name) then 294 | Just True 295 | else if (prefname == pren') then 296 | Just False else Nothing 297 | AppT ListT _ -> Just False 298 | _ -> Nothing) 299 | 300 | --customG :: Name -> Q (Either String Dec) -- Just one function 301 | --customG name = do 302 | -- def <- reify name 303 | -- let prefname = prefixT name 304 | -- case def of 305 | -- TyConI (TySynD _ params ty) -> --return $ Left "Syn" 306 | -- case (getTy ty) of 307 | -- (TupleT nu) -> 308 | -- let ns = map varT $ paramNames params 309 | -- lns = length ns 310 | -- in 311 | -- if lns > 0 then 312 | -- do 313 | -- [t] <- [d| instance $(applyTo (tupleT (length ns)) (map (appT (conT ''ProbGen)) ns)) 314 | -- => ProbGen $(applyTo (conT name) ns) where 315 | -- prob_gen xs 0 = $(genTupleArbs nu) 316 | -- prob_gen xs n = $(customTup 'xs 'n nu)|] 317 | -- return $ Right t 318 | -- else 319 | -- do 320 | -- [t] <- [d| instance ProbGen $(applyTo (conT name) ns) where 321 | -- prob_gen xs 0 = $(genTupleArbs nu) 322 | -- prob_gen xs n = $(customTup 'xs 'n nu) |] 323 | -- return $ Right t 324 | -- 325 | -- ConT n -> return $ Left $ "Already derived?" ++ show n 326 | -- d -> return $ Left $ "Not ready for " ++ show d 327 | -- 328 | -- TyConI (DataD _ _ params TH211MBKIND constructors _) -> 329 | -- let fnm = mkName "prob_gen" -- "customGen_" ++ (map (\x -> if x == '.' then '_' else 330 | -- --x) $ showName name) 331 | -- ns = map varT $ paramNames params 332 | -- f = (customFun fnm $ reverse (foldl (\p c -> -- because foldl 333 | -- let 334 | -- SimpleCon n rec vs = simpleConView n c 335 | -- tfs = prepareArgCons (prefname,name) vs 336 | -- in (n,tfs) : p) [] constructors)) 337 | -- in 338 | -- (instanceD (cxt $ (map (appT (conT ''Arbitrary)) ns) ++ (map (appT (conT ''ProbGen)) ns)) 339 | -- ( appT (conT ''ProbGen) (applyTo (conT name) ns)) 340 | -- [f]) 341 | -- >>= (return . Right) 342 | -- TyConI (NewtypeD _ _ params con _) -> 343 | -- let fnm = mkName "prob_gen" 344 | -- ns = map varT $ paramNames params 345 | -- SimpleCon n rec vs = simpleConView n con 346 | -- tfs = map (\ty -> case ty of 347 | -- ConT n' -> 348 | -- let pren' = prefixT n' 349 | -- in 350 | -- if (n' == name) then 351 | -- Just True 352 | -- else if (prefname == pren') then 353 | -- Just False else Nothing 354 | -- _ -> Nothing) vs 355 | -- f = customFunNewT fnm (n,tfs) 356 | -- in 357 | -- (instanceD (cxt $ (map (appT (conT ''Arbitrary)) ns) ++ (map (appT (conT ''ProbGen)) ns)) 358 | -- ( appT (conT ''ProbGen) (applyTo (conT name) ns)) 359 | -- [f]) 360 | -- >>= (return . Right) 361 | -- _ -> return $ Left "No TyConI" 362 | 363 | --createIntGen :: Name -> Q [Dec] 364 | --createIntGen n = do 365 | -- --arb <- devArbitrary n -- n should have and arbitrary instance, and doing so we get all the dependencies as well 366 | -- cstm <- customG n 367 | -- --let [FunD nm _] = cstm -- this is kinda horrible 368 | -- case cstm of 369 | -- Left s -> (runIO $ print $ "Pattern not implemented:" ++ s) >> return [] 370 | -- Right d -> return [d] 371 | 372 | --isGenName = isinsName ''ProbGen 373 | 374 | --instaGen :: Name -> Q [Dec] 375 | --instaGen mm = [d|instance ProbGen $(conT mm) where 376 | -- prob_gen _ n = resize n arbitrary |] 377 | -- 378 | --devIntGen :: Name -> Q [Dec] 379 | --devIntGen = megaderive createIntGen (const $ return False) isGenName 380 | ---} 381 | 382 | --------------------------------------------------------------------------------