diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015-2016 Tobias Dammers + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/Database/YeshQL/HDBC.hs b/src/Database/YeshQL/HDBC.hs new file mode 100644 --- /dev/null +++ b/src/Database/YeshQL/HDBC.hs @@ -0,0 +1,151 @@ +{-#LANGUAGE TemplateHaskell #-} +{-#LANGUAGE CPP #-} +{-#LANGUAGE RankNTypes #-} +{-#LANGUAGE FlexibleInstances #-} +{-| +Module: Database.YeshQL.HDBC +Description: Turn SQL queries into type-safe functions. +Copyright: (c) 2015-2017 Tobias Dammers +Maintainer: Tobias Dammers +Stability: experimental +License: MIT + + -} +module Database.YeshQL.HDBC +( +-- * Quasi-quoters that take strings + yesh, yesh1 +-- * Quasi-quoters that take filenames +, yeshFile, yesh1File +-- * Query parsers +, parseQuery +, parseQueries +-- * AST +, ParsedQuery (..) +) +where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +#if MIN_VERSION_template_haskell(2,7,0) +import Language.Haskell.TH.Syntax (Quasi(qAddDependentFile)) +#endif +import Data.List (isPrefixOf, foldl') +import Data.Maybe (catMaybes, fromMaybe) +import Database.HDBC (fromSql, toSql, run, runRaw, ConnWrapper, IConnection, quickQuery') +import qualified Text.Parsec as P +import Data.Char (chr, ord, toUpper, toLower) +import Control.Applicative ( (<$>), (<*>) ) +import System.FilePath (takeBaseName) +import Data.Char (isAlpha, isAlphaNum) + +import Database.YeshQL.Parser +import Database.YeshQL.Util +import Database.YeshQL.Backend +import Database.YeshQL.HDBC.SqlRow.Class + +yesh :: Yesh a => a +yesh = yeshWith hdbcBackend + +yesh1 :: Yesh a => a +yesh1 = yesh1With hdbcBackend + +yeshFile :: YeshFile a => a +yeshFile = yeshFileWith hdbcBackend + +yesh1File :: YeshFile a => a +yesh1File = yesh1FileWith hdbcBackend + +hdbcBackend :: YeshBackend +hdbcBackend = + YeshBackend + { ybNames = pqNames + , ybMkQueryBody = mkQueryBody + } + +pgQueryType :: ParsedQuery -> TypeQ +pgQueryType query = + [t|forall conn. IConnection conn => + $(foldr + (\a b -> [t| $a -> $b |]) + [t| conn -> IO $(returnType) |] + $ argTypes) + |] + where + argTypes = map (mkType . fromMaybe AutoType . pqTypeFor query) (pqParamNames query) + returnType = + if pqDDL query + then + tupleT 0 + else + case pqReturnType query of + ReturnRowCount tn -> mkType tn + ReturnTuple One [] -> tupleT 0 + ReturnTuple One (x:[]) -> appT [t|Maybe|] $ mkType x + ReturnTuple One xs -> appT [t|Maybe|] $ foldl' appT (tupleT $ length xs) (map mkType xs) + ReturnTuple Many [] -> tupleT 0 + ReturnTuple Many (x:[]) -> appT listT $ mkType x + ReturnTuple Many xs -> appT listT $ foldl' appT (tupleT $ length xs) (map mkType xs) + ReturnRecord One x -> appT [t|Maybe|] $ mkType x + ReturnRecord Many x -> appT listT $ mkType x + +mkType :: ParsedType -> Q Type +mkType (MaybeType n) = [t|Maybe $(conT . mkName $ n)|] +mkType (PlainType n) = conT . mkName $ n +mkType AutoType = [t|String|] + +pqNames :: ParsedQuery -> ([Name], [PatQ], String, TypeQ) +pqNames query = + let argNamesStr = pqParamNames query ++ ["conn"] + argNames = map mkName argNamesStr + patterns = map varP argNames + funName = pqQueryName query + queryType = pgQueryType query + in + (argNames, patterns, funName, queryType) + +mkQueryBody :: ParsedQuery -> Q Exp +mkQueryBody query = do + let (argNames, patterns, funName, queryType) = pqNames query + + convert :: ExpQ + convert = case pqReturnType query of + ReturnRowCount tn -> varE 'fromInteger + ReturnTuple _ [] -> [|\_ -> ()|] + ReturnTuple _ (x:[]) -> [|map (fromSql . head)|] + ReturnTuple _ xs -> + let varNames = map nthIdent [0..pred (length xs)] + in [|map $(lamE + -- \[a,b,c,...] -> + [(listP (map (varP . mkName) varNames))] + -- (fromSql a, fromSql b, fromSql c, ...) + (tupE $ (map (\n -> appE (varE 'fromSql) (varE . mkName $ n)) varNames)))|] + ReturnRecord _ x -> [|fromSqlRow|] + queryFunc = case pqReturnType query of + ReturnRowCount _ -> + [| \qstr params conn -> $convert <$> run conn qstr params |] + ReturnTuple Many _ -> + [| \qstr params conn -> $convert <$> quickQuery' conn qstr params |] + ReturnTuple One _ -> + [| \qstr params conn -> fmap headMay $ $convert <$> quickQuery' conn qstr params |] + ReturnRecord Many _ -> + [| \qstr params conn -> mapM $convert =<< quickQuery' conn qstr params |] + ReturnRecord One _ -> + [| \qstr params conn -> fmap headMay $ mapM $convert =<< quickQuery' conn qstr params |] + rawQueryFunc = [| \qstr conn -> runRaw conn qstr |] + if pqDDL query + then + rawQueryFunc + `appE` (litE . stringL . pqQueryString $ query) + `appE` (varE . mkName $ "conn") + else + queryFunc + `appE` (litE . stringL . pqQueryString $ query) + `appE` (listE (map paramArg $ pqParamsRaw query)) + `appE` (varE . mkName $ "conn") + + where + paramArg :: ExtractedParam -> ExpQ + paramArg (ExtractedParam n ps _) = do + let valE = foldl1 (flip appE) (map (varE . mkName) (n:ps)) + varE 'toSql `appE` valE diff --git a/src/Database/YeshQL/HDBC/SqlRow/Class.hs b/src/Database/YeshQL/HDBC/SqlRow/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/YeshQL/HDBC/SqlRow/Class.hs @@ -0,0 +1,104 @@ +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE DeriveGeneric #-} +{-#LANGUAGE DeriveFunctor #-} +{-#LANGUAGE GeneralizedNewtypeDeriving #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TemplateHaskell #-} +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE FlexibleContexts #-} +{-#LANGUAGE FlexibleInstances #-} +module Database.YeshQL.HDBC.SqlRow.Class +where + +import Database.HDBC +import Database.HDBC.SqlValue +import Data.Convertible (Convertible, prettyConvertError) +import Control.Applicative + +class ToSqlRow a where + toSqlRow :: a -> [SqlValue] + +instance ToSqlRow [SqlValue] where + toSqlRow = id + +newtype Parser a = + Parser { runParser :: [SqlValue] -> Either String (a, [SqlValue]) } + deriving (Functor) + +instance Applicative Parser where + pure x = Parser $ \values -> Right (x, values) + (<*>) = parserApply + +instance Alternative Parser where + empty = parserFail "" + (<|>) = parserAlt + +parserAlt :: Parser a -> Parser a -> Parser a +parserAlt (Parser rpa) (Parser rpb) = + Parser $ \values -> + case rpa values of + Right x -> + Right x + Left err -> + case rpb values of + Right x -> + Right x + Left err' -> + Left (mergeErrors err err') + +mergeErrors :: String -> String -> String +mergeErrors "" x = x +mergeErrors x "" = x +mergeErrors x y = x ++ "\n" ++ y + +parserApply :: Parser (a -> b) -> Parser a -> Parser b +parserApply (Parser rpf) (Parser rpa) = + Parser $ \values -> + case rpf values of + Left err -> Left err + Right (f, values') -> + case rpa values' of + Left err -> Left err + Right (a, values'') -> + Right (f a, values'') + +instance Monad Parser where + (>>=) = parserBind + fail = parserFail + +parserFail :: String -> Parser a +parserFail err = + Parser . const . Left $ err + +parserBind :: Parser a -> (a -> Parser b) -> Parser b +parserBind p f = + let g = runParser p + in Parser $ \values -> case g values of + Left err -> Left err + Right (x, values') -> runParser (f x) values' + +class FromSqlRow a where + parseSqlRow :: Parser a + +fromSqlRow :: (FromSqlRow a, Monad m) => [SqlValue] -> m a +fromSqlRow sqlValues = + case runParser parseSqlRow sqlValues of + Left err -> fail err + Right (value, _) -> return value + +class (ToSqlRow a, FromSqlRow a) => SqlRow a where + +parseField :: Convertible SqlValue a => Parser a +parseField = Parser $ \case + [] -> Left "Not enough columns in result set" + (x:xs) -> case safeFromSql x of + Left cerr -> Left . prettyConvertError $ cerr + Right a -> Right (a, xs) + +eof :: Parser () +eof = Parser $ \case + [] -> Right ((), []) + _ -> Left "Expected end of input" + +instance FromSqlRow [SqlValue] where + parseSqlRow = many parseField diff --git a/src/Database/YeshQL/HDBC/SqlRow/TH.hs b/src/Database/YeshQL/HDBC/SqlRow/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/YeshQL/HDBC/SqlRow/TH.hs @@ -0,0 +1,129 @@ +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE DeriveGeneric #-} +{-#LANGUAGE TemplateHaskell #-} +{-#LANGUAGE QuasiQuotes #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE CPP #-} +module Database.YeshQL.HDBC.SqlRow.TH +( makeSqlRow +) +where + +import Database.YeshQL.HDBC.SqlRow.Class +import Database.HDBC (fromSql, toSql) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +makeSqlRow :: Name -> Q [Dec] +makeSqlRow entityName = do + (TyConI d) <- reify entityName + (typeName, _, constructors) <- typeInfo d + + (constructorName, fieldNames, fieldTypes) <- + case constructors of + [(constructorName, _, Just fieldNames, fieldTypes)] -> + return (constructorName, fieldNames, fieldTypes) + _ -> fail "Unsuitable type for deriving SqlRow" + + [d| + instance ToSqlRow $(conT typeName) where + toSqlRow entity = + $(listE $ map (toSqlRowField 'entity) fieldNames) + + instance FromSqlRow $(conT typeName) where + parseSqlRow = Parser $ \case + $(foldr + (\x xs -> infixP x '(:) xs) + (varP $ mkName "remaining") + (map fromSqlPatternItem fieldNames) + ) -> + return + ( $(foldl1 appE $ + conE constructorName : map fromSqlPatternArg fieldNames) + , remaining + ) + _ -> fail $ "Invalid SQL for " ++ $(litE . stringL . nameBase $ typeName) |] + where + toSqlRowField :: Name -> Name -> ExpQ + toSqlRowField entityName fieldName = + appE [|toSql|] $ appE (varE fieldName) (varE entityName) + + fromSqlPatternItem :: Name -> PatQ + fromSqlPatternItem fieldName = + varP (mkName $ "sql_" ++ nameBase fieldName) + + fromSqlPatternArg :: Name -> ExpQ + fromSqlPatternArg fieldName = + appE + (varE (mkName "fromSql")) + (varE (mkName $ "sql_" ++ nameBase fieldName)) + +{- + +Subsequent code taken from syb-with-class, under the following license: + +Copyright (c) 2004 - 2008 The University of Glasgow, CWI, + Simon Peyton Jones, Ralf Laemmel, + Ulf Norell, Sean Seefried, Simon D. Foster, + HAppS LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + +-} + +type Constructor = + (Name, -- Name of the constructor + Int, -- Number of constructor arguments + Maybe [Name], -- Name of the field selector, if any + [Type]) -- Type of the constructor argument + +typeInfo :: Dec + -> Q (Name, -- Name of the datatype + [Name], -- Names of the type parameters + [Constructor]) -- The constructors +typeInfo d + = case d of +#if MIN_VERSION_template_haskell(2,11,0) + DataD _ n ps _ cs _ -> return (n, map varName ps, map conA cs) + NewtypeD _ n ps _ c _ -> return (n, map varName ps, [conA c]) +#else + DataD _ n ps cs _ -> return (n, map varName ps, map conA cs) + NewtypeD _ n ps c _ -> return (n, map varName ps, [conA c]) +#endif + _ -> error ("derive: not a data type declaration: " ++ show d) + where + conA (NormalC c xs) = (c, length xs, Nothing, map snd xs) + conA (InfixC x1 c x2) = conA (NormalC c [x1, x2]) + conA (ForallC _ _ c) = conA c + conA (RecC c xs) = + let getField (n, _, _) = n + getType (_, _, t) = t + fields = map getField xs + types = map getType xs + in (c, length xs, Just fields, types) + varName (PlainTV n) = n + varName (KindedTV n _) = n diff --git a/tests/Database/HDBC/Mock.hs b/tests/Database/HDBC/Mock.hs new file mode 100644 --- /dev/null +++ b/tests/Database/HDBC/Mock.hs @@ -0,0 +1,235 @@ +-- | Mock HDBC database connection for unit testing purposes. +module Database.HDBC.Mock +( +-- * Mock Connections + MockConnection (..) +, defMockConnection +-- * Logging interaction +, loggingConnection +-- * Chat Scripts +, newChatConnection +, ChatStep (..) +-- * Constraints +-- The Contraint API is a minilanguage for declaring and combining constraints +-- on arbitrary values. +, Constraint +-- | Construct a constraint from a raw predicate. +, constraint +-- | Check a constraint against a value. +, check +-- | Check a list of constraints against a list of values. +, checkAll +-- | A constraint that matches a value exactly (as per 'Eq' / '==') +, exactly +-- | A constraint that matches a value by a comparison function +, sameBy +-- | A constraint that matches a value exactly after applying some pre-processing +, sameThrough +-- | A constraint that matches any value +, anything +-- | The inclusive-OR operator on 'Constraint's. +, (<||>) +) +where + +import Database.HDBC + ( IConnection (..) + , SqlValue (..) + , SqlColDesc (..) + ) +import Database.HDBC.Statement + ( Statement (..) + ) +import Control.Monad (forM_, when) +import Control.Concurrent.STM (atomically, STM) +import Control.Concurrent.STM.TChan + ( TChan + , newTChan + , writeTChan + , readTChan + , tryReadTChan + , newTChanIO + ) + +data MockConnection = + MockConnection + { mockDisconnect :: IO () + , mockCommit :: IO () + , mockRollback :: IO () + , mockRun :: String -> [SqlValue] -> IO Integer + , mockPrepare :: String -> IO Statement + , mockClone :: IO MockConnection + , mockTransactionSupport :: Bool + , mockGetTables :: IO [String] + , mockDescribeTable :: String -> IO [(String, SqlColDesc)] + } + +defMockConnection :: MockConnection +defMockConnection = + MockConnection + { mockDisconnect = return () + , mockCommit = return () + , mockRollback = return () + , mockRun = \q p -> fail "'run' method not implemented" + , mockPrepare = \q -> fail "'prepare' method not implemented" + , mockClone = fail "'clone' method not implemented" + , mockTransactionSupport = False + , mockGetTables = return [] + , mockDescribeTable = const $ return [] + } + +instance IConnection MockConnection where + disconnect = mockDisconnect + commit = mockCommit + rollback = mockRollback + run = mockRun + prepare = mockPrepare + clone = mockClone + hdbcDriverName = const "mock" + hdbcClientVer = const "0.0" + dbServerVer = const "0.0" + dbTransactionSupport = mockTransactionSupport + getTables = mockGetTables + describeTable = mockDescribeTable + +tee :: (a -> IO ()) -> IO a -> IO a +tee sideChannel action = do + retval <- action + sideChannel retval + return retval + +loggingStatement :: String -> (String -> IO ()) -> Statement -> Statement +loggingStatement query log stmt = + stmt + { execute = \params -> do + log $ "execute " ++ show query ++ " with " ++ show params + tee (log . show) $ execute stmt params + , executeRaw = do + log $ "executeRaw " ++ show query + tee (log . show) $ executeRaw stmt + , executeMany = \rows -> do + log $ "executeMany " ++ show query ++ " with: " + forM_ rows $ \params -> log $ " " ++ show params + tee (log . show) $ executeMany stmt rows + , finish = do + log $ "finish" + finish stmt + } + +loggingConnection :: IConnection conn => (String -> IO ()) -> conn -> MockConnection +loggingConnection log conn = + defMockConnection + { mockDisconnect = do + log "disconnect" + disconnect conn + , mockCommit = do + log "commit" + commit conn + , mockRollback = do + log "rollback" + rollback conn + , mockRun = \q p -> do + log $ "run " ++ show q ++ " with " ++ show p + tee (log . show) $ run conn q p + , mockPrepare = \q -> do + log $ "prepare " ++ show q + loggingStatement q log <$> prepare conn q + , mockClone = do + log $ "clone" + loggingConnection log <$> clone conn + , mockTransactionSupport = dbTransactionSupport conn + , mockGetTables = do + log $ "getTables" + tee (log . show) $ getTables conn + , mockDescribeTable = \tbl -> do + log $ "describeTable " ++ tbl + tee (log . show) $ describeTable conn tbl + } + +tChanFromList :: [a] -> IO (TChan a) +tChanFromList xs = atomically $ do + newTChan >>= fillTChanFromList xs + +fillTChanFromList :: [a] -> (TChan a) -> STM (TChan a) +fillTChanFromList xs c = do + forM_ xs $ writeTChan c + return c + +newtype Constraint a = Constraint { check :: a -> Bool } + +instance Monoid (Constraint a) where + mempty = anything + mappend (Constraint a) (Constraint b) = + Constraint (\x -> a x && b x) + +(<||>) :: Constraint a -> Constraint a -> Constraint a +a <||> b = Constraint $ \x -> check a x || check b x + +constraint :: (a -> Bool) -> Constraint a +constraint = Constraint + +exactly :: Eq a => a -> Constraint a +exactly = sameBy (==) + +sameThrough :: Eq a => (a -> a) -> a -> Constraint a +sameThrough pp lhs = constraint $ \rhs -> pp lhs == pp rhs + +sameBy :: (a -> a -> Bool) -> a -> Constraint a +sameBy cmp val = constraint $ cmp val + +anything :: Constraint a +anything = constraint (const True) + +data ChatStep = + ChatStep + { chatQuery :: Constraint String + , chatParams :: [Constraint SqlValue] + , chatResultSet :: [[SqlValue]] + , chatColumnNames :: [String] + , chatRowsAffected :: Integer + } + +checkAll :: [Constraint a] -> [a] -> Bool +checkAll constraints values = + all id $ zipWith check constraints values + +execChatStep :: String -> [SqlValue] -> TChan [SqlValue] -> ChatStep -> IO Integer +execChatStep query params resultChan step = do + when (not $ check (chatQuery step) query) $ + fail $ + "Chat script mismatch: unexpected query:\n\t" ++ + query + when (not $ checkAll (chatParams step) params) $ + fail $ + "Parameter mismatch: got " ++ show params + atomically $ fillTChanFromList (chatResultSet step) resultChan + return $ chatRowsAffected step + +newChatConnection :: [ChatStep] -> IO MockConnection +newChatConnection steps = do + c <- tChanFromList steps + mkChatConnection c + where + mkChatConnection c = + return $ defMockConnection + { mockRun = \q p -> do + resultVar <- newTChanIO + step <- atomically $ readTChan c + execChatStep q p resultVar step + , mockPrepare = \q -> do + resultVar <- newTChanIO + let exec p = do + atomically (readTChan c) >>= execChatStep q p resultVar + return $ + Statement + { execute = exec + , executeRaw = exec [] >> return () + , executeMany = \ps -> mapM exec ps >> return () + , finish = return () + , fetchRow = atomically $ tryReadTChan resultVar + , getColumnNames = return [] + , originalQuery = q + , describeResult = return [] + } + , mockClone = mkChatConnection c + } diff --git a/tests/Database/YeshQL/HDBC/SimulationTests.hs b/tests/Database/YeshQL/HDBC/SimulationTests.hs new file mode 100644 --- /dev/null +++ b/tests/Database/YeshQL/HDBC/SimulationTests.hs @@ -0,0 +1,422 @@ +{-#LANGUAGE QuasiQuotes #-} +{-#LANGUAGE RankNTypes #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TemplateHaskell #-} +module Database.YeshQL.HDBC.SimulationTests +( tests +) +where + +import Test.Tasty +import Test.Tasty.HUnit +import Database.HDBC +import Database.HDBC.Mock +import Database.YeshQL.HDBC +import Database.YeshQL.HDBC.SqlRow.Class +import Database.YeshQL.HDBC.SqlRow.TH +import System.IO +import Data.Char +import Data.List (dropWhile, dropWhileEnd) + +data User = + User + { userID :: Int + , userName :: String + } + deriving (Show, Eq) +makeSqlRow ''User + +data Person = + Person + { personName :: String + , personEmail :: String + } + deriving (Show, Eq) +makeSqlRow ''Person + +data UserData = + UserData + { user :: User + , person :: Person + } + deriving (Show, Eq) + +instance ToSqlRow UserData where + toSqlRow d = (toSqlRow . user $ d) ++ (toSqlRow . person $ d) + +instance FromSqlRow UserData where + parseSqlRow = UserData <$> parseSqlRow <*> parseSqlRow + +tests = + [ testSimpleSelect + , testSimpleSelectStr + , testParametrizedSelect + , testSingleInsert + , testRecordReturn + , testRecordReturnComplex + , testRecordReturnExcessive + , testRecordParams + , testUpdateReturnRowCount + , testMultiQuery + , testQueryFromFile + , testQueryFromFileAutoName + , testManyQueriesFromFileAutoName + , testDDL + ] + +testSimpleSelect :: TestTree +testSimpleSelect = testCase "Simple SELECT" $ chatTest chatScript $ \conn -> do + results <- [yesh| + -- name:getUserByName :: (String) + SELECT username FROM users|] conn + return () + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT username FROM users" + , chatParams = [] + , chatResultSet = [] + , chatColumnNames = ["username"] + , chatRowsAffected = 0 + } + ] + +testSimpleSelectStr :: TestTree +testSimpleSelectStr = testCase "Simple SELECT (expr by string)" $ chatTest chatScript $ \conn -> do + results <- $(yesh $ unlines + [ "-- name:getUserByName :: (String)" + , "SELECT username FROM users" + ]) conn + return () + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT username FROM users" + , chatParams = [] + , chatResultSet = [] + , chatColumnNames = ["username"] + , chatRowsAffected = 0 + } + ] + +testParametrizedSelect :: TestTree +testParametrizedSelect = testCase "Parametrized SELECT" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:getUserByName :: (Integer, String) + -- :username :: String + SELECT id, username FROM users WHERE username = :username LIMIT 1|] "billy" conn + let expected :: Maybe (Integer, String) + expected = Just (1, "billy") + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1" + , chatParams = [exactly (toSql "billy")] + , chatResultSet = [[toSql (1 :: Int), toSql "billy"]] + , chatColumnNames = ["username"] + , chatRowsAffected = 0 + } + ] + +testRecordReturn :: TestTree +testRecordReturn = testCase "Return record from SELECT" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:getUserByName :: User + -- :username :: String + SELECT id, username FROM users WHERE username = :username LIMIT 1|] + "billy" + conn + let expected :: Maybe User + expected = Just $ User 1 "billy" + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1" + , chatParams = [exactly (toSql "billy")] + , chatResultSet = [[toSql (1 :: Int), toSql "billy"]] + , chatColumnNames = ["username"] + , chatRowsAffected = 0 + } + ] + +testRecordReturnComplex :: TestTree +testRecordReturnComplex = testCase "Return record from SELECT" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:getUserByName :: UserData + -- :username :: String + SELECT id, username, person_name, email FROM users WHERE username = :username LIMIT 1|] + "billy" + conn + let expected :: Maybe UserData + expected = Just $ UserData (User 1 "billy") (Person "Billy" "billy@example.org") + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT id, username, person_name, email FROM users WHERE username = ? LIMIT 1" + , chatParams = [exactly (toSql "billy")] + , chatResultSet = + [ + [ toSql (1 :: Int) + , toSql "billy" + , toSql "Billy" + , toSql "billy@example.org" + ] + ] + , chatColumnNames = ["username", "person_name", "email"] + , chatRowsAffected = 0 + } + ] + +testRecordReturnExcessive :: TestTree +testRecordReturnExcessive = testCase "Return record from SELECT (extra values ignored)" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:getUserByName :: User + -- :username :: String + SELECT id, username FROM users WHERE username = :username LIMIT 1|] + "billy" + conn + let expected :: Maybe User + expected = Just $ User 1 "billy" + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1" + , chatParams = [exactly (toSql "billy")] + , chatResultSet = [[toSql (1 :: Int), toSql "billy", toSql "willie"]] + , chatColumnNames = ["username"] + , chatRowsAffected = 0 + } + ] + +testRecordParams :: TestTree +testRecordParams = testCase "Pass records as params" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:getUserByName :: User + -- :user :: User + SELECT id, username FROM users WHERE username = :user.userName.reverse LIMIT 1|] + (User 10 "yllib") + conn + let expected :: Maybe User + expected = Just $ User 1 "billy" + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1" + , chatParams = [exactly (toSql "billy")] + , chatResultSet = [[toSql (1 :: Int), toSql "billy"]] + , chatColumnNames = ["username"] + , chatRowsAffected = 0 + } + ] + +testSingleInsert :: TestTree +testSingleInsert = testCase "Single INSERT" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:createUser :: (Integer) + -- :username :: String + INSERT INTO users (username) VALUES (:username) RETURNING id|] "billy" conn + let expected :: Maybe Integer + expected = Just 23 + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim "INSERT INTO users (username) VALUES (?) RETURNING id" + , chatParams = [exactly $ toSql "billy"] + , chatResultSet = [[toSql (23 :: Int)]] + , chatColumnNames = ["id"] + , chatRowsAffected = 1 + } + ] + +testUpdateReturnRowCount :: TestTree +testUpdateReturnRowCount = testCase "UPDATE, get row count" $ chatTest chatScript $ \conn -> do + actual <- [yesh| + -- name:renameUser :: rowcount Integer + -- :oldName :: String + -- :newName :: String + UPDATE users SET username = :oldName WHERE username = :newName AND username <> :oldName|] + "tony" "billy" conn + let expected :: Integer + expected = 1 + assertEqual "" expected actual + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim + "UPDATE users SET username = ? WHERE username = ? AND username <> ?" + , chatParams = + [ exactly $ toSql "tony" + , exactly $ toSql "billy" + , exactly $ toSql "tony" + ] + , chatResultSet = [] + , chatColumnNames = [] + , chatRowsAffected = 1 + } + ] + +[yesh| + -- name:findUser :: (Int) + -- :username :: String + SELECT id FROM users WHERE username = :username + ;;; + -- name:setUserName :: rowcount Integer + -- :userID :: Int + -- :username :: String + UPDATE users SET username = :username WHERE id = :userID +|] + +testMultiQuery :: TestTree +testMultiQuery = testCase "Define multiple queries in one QQ inside a where" $ chatTest chatScript $ \conn -> do + userID <- maybe (fail "User Not Found") return =<< findUser "billy" conn + rowCount <- setUserName userID "tony" conn + assertEqual "" rowCount 1 + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim + "SELECT id FROM users WHERE username = ?" + , chatParams = + [ exactly $ toSql "billy" + ] + , chatResultSet = [[toSql (1 :: Int)]] + , chatColumnNames = ["id"] + , chatRowsAffected = 0 + } + , ChatStep + { chatQuery = sameThrough trim + "UPDATE users SET username = ? WHERE id = ?" + , chatParams = + [ exactly $ toSql "tony" + , exactly $ toSql (1 :: Int) + ] + , chatResultSet = [] + , chatColumnNames = [] + , chatRowsAffected = 1 + } + ] + +testQueryFromFile :: TestTree +testQueryFromFile = testCase "Query loaded from fixture file" $ + chatTest chatScript $ \conn -> do + [(userID, username)] <- [yesh1File|tests/fixtures/getUserNamed.sql|] 1 conn + assertEqual "" userID 1 + assertEqual "" username "billy" + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim + "SELECT id, username FROM users WHERE id = ?" + , chatParams = + [ exactly $ toSql (1 :: Int) + ] + , chatResultSet = [[toSql (1 :: Int), toSql "billy"]] + , chatColumnNames = ["id", "username"] + , chatRowsAffected = 0 + } + ] + +[yesh1File|tests/fixtures/getUser.sql|] + +testQueryFromFileAutoName :: TestTree +testQueryFromFileAutoName = testCase "Query loaded from fixture file, deriving query name from filename" $ + chatTest chatScript $ \conn -> do + [(userID, username)] <- getUser 1 conn + assertEqual "" userID 1 + assertEqual "" username "billy" + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim + "SELECT id, username FROM users WHERE id = ?" + , chatParams = + [ exactly $ toSql (1 :: Int) + ] + , chatResultSet = [[toSql (1 :: Int), toSql "billy"]] + , chatColumnNames = ["id", "username"] + , chatRowsAffected = 0 + } + ] + +[yeshFile|tests/fixtures/multiQueries.sql|] + +testManyQueriesFromFileAutoName :: TestTree +testManyQueriesFromFileAutoName = testCase "Many queries from fixture file, auto-naming some" $ + chatTest chatScript $ \conn -> do + count0 <- multiQueries_0 conn + count1 <- multiQueriesNamed conn + count2 <- multiQueries_2 conn + assertEqual "" count0 1 + assertEqual "" count1 2 + assertEqual "" count2 3 + where + chatScript = + [ ChatStep + { chatQuery = sameThrough trim + "BLAH" + , chatParams = + [] + , chatResultSet = [] + , chatColumnNames = [] + , chatRowsAffected = 1 + } + , ChatStep + { chatQuery = sameThrough trim + "PIZZA" + , chatParams = + [] + , chatResultSet = [] + , chatColumnNames = [] + , chatRowsAffected = 2 + } + , ChatStep + { chatQuery = sameThrough trim + "OLIVES" + , chatParams = + [] + , chatResultSet = [] + , chatColumnNames = [] + , chatRowsAffected = 3 + } + ] + +testDDL :: TestTree +testDDL = testCase "typical DDL statement sequence" $ + chatTest chatScript + [yesh1| + -- @ddl + CREATE TABLE users + ( id INTEGER + , username TEXT + ); + CREATE TABLE pages + ( id INTEGER + , owner_id INTEGER + , title TEXT + , body TEXT + , FOREIGN KEY (owner_id) REFERENCES users (id) + ); + |] + where + chatScript = + [ ChatStep + { chatQuery = anything + , chatParams = [] + , chatResultSet = [] + , chatColumnNames = [] + , chatRowsAffected = 0 + } + ] + +chatTest :: [ChatStep] -> (forall conn. IConnection conn => conn -> IO ()) -> Assertion +chatTest chatScript action = + newChatConnection chatScript >>= action + +trim :: String -> String +trim = dropWhile isSpace . dropWhileEnd isSpace diff --git a/tests/fixtures/getUser.sql b/tests/fixtures/getUser.sql new file mode 100644 --- /dev/null +++ b/tests/fixtures/getUser.sql @@ -0,0 +1,3 @@ +-- :: [(Int, String)] +-- :userID :: Int +SELECT id, username FROM users WHERE id = :userID diff --git a/tests/fixtures/getUserNamed.sql b/tests/fixtures/getUserNamed.sql new file mode 100644 --- /dev/null +++ b/tests/fixtures/getUserNamed.sql @@ -0,0 +1,3 @@ +-- name:getUserA :: [(Int, String)] +-- :userID :: Int +SELECT id, username FROM users WHERE id = :userID diff --git a/tests/fixtures/multiQueries.sql b/tests/fixtures/multiQueries.sql new file mode 100644 --- /dev/null +++ b/tests/fixtures/multiQueries.sql @@ -0,0 +1,7 @@ +-- :: rowcount Integer +BLAH +;;; +-- name: multiQueriesNamed :: rowcount Integer +PIZZA +;;; +OLIVES diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,12 @@ +{-#LANGUAGE TemplateHaskell #-} +{-#LANGUAGE QuasiQuotes #-} +module Main where + +import Test.Tasty +import qualified Database.YeshQL.HDBC.SimulationTests as SimulationTests + +main = defaultMain allTests + where + allTests = testGroup "All Tests" + [ testGroup "Simulation Tests" SimulationTests.tests + ] diff --git a/yeshql-hdbc.cabal b/yeshql-hdbc.cabal new file mode 100644 --- /dev/null +++ b/yeshql-hdbc.cabal @@ -0,0 +1,52 @@ +name: yeshql-hdbc +version: 4.1.0.0 +synopsis: YesQL-style SQL database abstraction (HDBC backend) +description: Use quasi-quotations or TemplateHaskell to write SQL in SQL, while + adding type annotations to turn SQL into well-typed Haskell + functions. +homepage: https://github.com/tdammers/yeshql +bug-reports: https://github.com/tdammers/yeshql/issues +license: MIT +license-file: LICENSE +author: Tobias Dammers +maintainer: tdammers@gmail.com +copyright: 2015-2017 Tobias Dammers and contributors +category: Database +build-type: Simple +extra-source-files: tests/fixtures/*.sql +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/tdammers/yeshql.git + +library + exposed-modules: Database.YeshQL.HDBC + , Database.YeshQL.HDBC.SqlRow.Class + , Database.YeshQL.HDBC.SqlRow.TH + -- other-extensions: + build-depends: base >=4.6 && <5.0 + , yeshql-core >= 4.0 && <5.0 + , HDBC >= 2.4 && <3.0 + , containers >= 0.5 && < 1.0 + , filepath + , parsec >= 3.0 && <4.0 + , template-haskell + , convertible >= 1.1.1.0 && <2 + hs-source-dirs: src + default-language: Haskell2010 +test-suite tests + type: exitcode-stdio-1.0 + build-depends: base >=4.6 && <5.0 + , yeshql-hdbc + , containers + , stm + , tasty + , tasty-hunit + , tasty-quickcheck + , HDBC + hs-source-dirs: tests + main-is: tests.hs + other-modules: Database.YeshQL.HDBC.SimulationTests + , Database.HDBC.Mock + default-language: Haskell2010