{-# LANGUAGE OverloadedStrings , ScopedTypeVariables , FlexibleInstances , FlexibleContexts , TemplateHaskell #-} module Puretests where import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromString) import Control.Applicative import Data.Attoparsec.Text.Lazy import Data.Decimal import Data.Derive.Arbitrary import Data.DeriveTH import Data.List (intercalate, isInfixOf, mapAccumL, intersperse) import Data.Monoid (mconcat) import Data.UUID (UUID, fromWords) import Database.HDBI import Database.HDBI.PostgreSQL.Implementation import Database.HDBI.PostgreSQL.Parser import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.HUnit (assertFailure, Assertion, (@?=)) import Test.QuickCheck import Test.QuickCheck.Assertions import Test.QuickCheck.Instances () import qualified Data.ByteString as B import qualified Data.Text.Lazy as TL import qualified Test.QuickCheck.Monadic as QM import qualified Test.QuickCheck.Property as QP instance Arbitrary (DecimalRaw Integer) where arbitrary = Decimal <$> arbitrary <*> arbitrary instance Arbitrary UUID where arbitrary = fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary BitField where arbitrary = BitField <$> arbitrary $( derive makeArbitrary ''SqlValue ) isID :: (Eq a, Show a) => (a -> b) -> (b -> a) -> a -> QP.Result isID to from a = a ==? (from $ to a) sqlToNativeAndBack :: SqlValue -> Property sqlToNativeAndBack val = QM.monadicIO $ do res <- QM.run $ do let nat = sqlValueToNative val case nat of Nothing -> return SqlNull Just (o, b, f) -> nativeToSqlValue b f o QM.stop $ scompare val res where scompare (SqlDouble a) (SqlDouble b) = a ~==? b scompare a b = a ==? b convertionTests :: Test convertionTests = testGroup "Can convert to and back" [testProperty "SqlValue" sqlToNativeAndBack] parseToLeft :: (Show a) => Parser a -> TL.Text -> Assertion parseToLeft p t = case eitherResult $ parse p t of Left _ -> return () Right r -> assertFailure $ "string " ++ (show t) ++ " parsed to " ++ show r formatParseFail :: String -- ^ Initial string -> [String] -- ^ context -> String -- ^ error message -> String formatParseFail s cts err = "string " ++ (show s) ++ "\ncontext: " ++ (intercalate ", " cts) ++ "\nerror: " ++ err parseToRight :: Parser a -> TL.Text -> Assertion parseToRight p t = case parse p t of Fail _ cts err -> assertFailure $ formatParseFail (TL.unpack t) cts err Done _ _ -> return () testParseQidentifier :: Assertion testParseQidentifier = do parseToRight qidentifier "\"hello\"" parseToRight qidentifier "\" efs a \"" parseToRight qidentifier "\"\"" parseToRight qidentifier "\"jas\"\"jas\"\"\"" parseToRight qidentifier "\"\"\"\"" parseToLeft qidentifier " asdf \"" parseToLeft qidentifier "\" ijasdf " parseToLeft qidentifier "\"ja\"\"" testQuoteLiteral :: Assertion testQuoteLiteral = do parseToRight quoteLiteral "''" parseToRight quoteLiteral "'aije'" parseToRight quoteLiteral "' asdf '''" parseToRight quoteLiteral "' asdfij \\''" parseToRight quoteLiteral "'\\'''''\\'\\''''" parseToRight quoteLiteral "''' asidfj '''" parseToRight quoteLiteral "'afe\\\\s''fa'" parseToLeft quoteLiteral "adf'" -- started not from quote parseToLeft quoteLiteral "'aijfa\\'" -- no end quote parseToLeft quoteLiteral "'ssd''" testDollarLiteral :: Assertion testDollarLiteral = do parseToRight dollarLiteral "$$$$" parseToRight dollarLiteral "$tag$$tag$" parseToRight dollarLiteral "$asdf$\"jiasd$$f 'j ija\"$asdf$" parseToRight dollarLiteral "$tag$$$$$$ajs$$$tag$" parseToLeft dollarLiteral "$a$jaisdj$$" -- tag mismatch parseToLeft dollarLiteral "$a$ aisj\\$a $" parseToLeft dollarLiteral "$4sf$hello$4sf$" -- tag started with digit testInlineComment :: Assertion testInlineComment = do parseToRight ccomment "/**/" parseToRight ccomment "/* asdf */" parseToRight ccomment "/*ja e /* jasd */*/" -- inlined comment parseToRight ccomment "/* ij/ * iajef */" parseToRight ccomment "/*/*/**/*/*/" parseToLeft ccomment " jae */" -- no start /* parseToLeft ccomment "/* asdf " -- no end */ testLineComment :: Assertion testLineComment = do parseToRight linecomment "--" parseToRight linecomment "-- jijasdf " parseToRight linecomment "-- jasdf sj\n" parseToLeft linecomment "a-- jasd" -- not started from -- buildsTo :: Query -> B.ByteString -> Assertion buildsTo q res = (buildSqlQuery q) @?= res testQueryBuilder :: Assertion testQueryBuilder = do buildsTo "\"hello?\" ?" "\"hello?\" $1" buildsTo "'?', ?" "'?', $1" buildsTo "select \"a?\\?\"\"?\" from \"?\"\" \" where fld = ? and ff = 'con?t''' ?" "select \"a?\\?\"\"?\" from \"?\"\" \" where fld = $1 and ff = 'con?t''' $2" parserTests :: Test parserTests = testGroup "Parser tests" [ testCase "qidentifier parser" testParseQidentifier , testCase "quote literal string parser" testQuoteLiteral , testCase "dollar literal string parser" testDollarLiteral , testCase "inline comment parser" testInlineComment , testCase "line comment parser" testLineComment , testCase "complex query builder test" testQueryBuilder ] alphabet :: [String] alphabet = (map (:[]) "qwertyuiop[]asdfghjklzxcvbnm,. ?") ++ ["- "] parseRightProperty :: Parser a -> String -> QP.Result parseRightProperty p s = case parse p $ TL.pack s of Done _ _ -> QP.succeeded Fail _ cont err -> QP.failed {QP.reason = formatParseFail s cont err} quoteLiteralGen :: Gen String quoteLiteralGen = do r <- listOf $ elements $ ["''", "\\'"] ++ alphabet return $ "'" ++ concat r ++ "'" dollarLiteralGen :: Gen String dollarLiteralGen = do tag <- concat <$> (listOf $ elements $ alphabet ++ ["''", "\\'", "\"", "\\\"", "\"\""]) let quotes = "$" ++ tag ++ "$" body <- suchThat (concat <$> (listOf $ elements $ alphabet ++ ["$", "''", "\\'", "\"", "\\\"", "\"\""])) $ not . (isInfixOf quotes) . (++ "$") return $ quotes ++ body ++ quotes qidentifierGen :: Gen String qidentifierGen = do body <- concat <$> (listOf $ elements $ alphabet ++ ["'", "\\'", "\"\"", "$"]) return $ "\"" ++ body ++ "\"" inlineCommentGen :: Gen String inlineCommentGen = do body <- oneof [ inlineCommentGen , concat <$> (listOf $ elements $ alphabet) ] return $ "/*" ++ body ++ "*/" lineCommentGen :: Gen String lineCommentGen = do body <- concat <$> (listOf $ elements alphabet) end <- elements ["", "\n"] return $ "--" ++ body ++ end parameterPlaceholderGen :: Gen String parameterPlaceholderGen = do (v :: Int) <- getPositive <$> arbitrary return $ "$" ++ (show v) data GenS = GenQ String -- ^ Generate string as is | GenR -- ^ Generate $1, $2 sequence in this place generateQueryPiece :: Gen (String, GenS) -- initial string and the result generateQueryPiece = oneof [ quote quoteLiteralGen , quote dollarLiteralGen , quote qidentifierGen , quote inlineCommentGen , quote parameterPlaceholderGen , quote ((++ "\n") <$> lineCommentGen) -- , quote $ return "\\?" , return ("?", GenR) ] where quote p = do r <- p return (r, GenQ r) pieceToResult :: [(String, GenS)] -> [(String, String)] pieceToResult p = snd $ mapAccumL accl 1 p where accl acc (x, GenQ y) = (acc, (x, y)) accl acc (x, GenR) = (acc+1, (x, "$" ++ show acc)) fullQueryGen :: Gen (Query, B.ByteString) fullQueryGen = do (q, res) <- unzip . (intersperse (" ", " ")) . pieceToResult <$> (listOf generateQueryPiece) return $ (Query $ TL.pack $ concat q, toByteString $ mconcat $ map fromString res) checkFullQueryGen :: (Query, B.ByteString) -> QP.Result checkFullQueryGen (q, res) = (buildSqlQuery q) ?== res parserProperties :: Test parserProperties = testGroup "Parser properties" [ testProperty "literal" $ forAll quoteLiteralGen $ parseRightProperty literal , testProperty "dollar literal" $ forAll dollarLiteralGen $ parseRightProperty dollarLiteral , testProperty "qidentifier" $ forAll qidentifierGen $ parseRightProperty qidentifier , testProperty "inline comment" $ forAll inlineCommentGen $ parseRightProperty ccomment , testProperty "line comment" $ forAll lineCommentGen $ parseRightProperty linecomment , testProperty "whole parser" $ forAll fullQueryGen checkFullQueryGen ] main :: IO () main = defaultMain [ convertionTests , parserTests , parserProperties ]