yeshql-hdbc (empty) → 4.1.0.0
raw patch · 11 files changed
+1138/−0 lines, 11 filesdep +HDBCdep +basedep +containers
Dependencies added: HDBC, base, containers, convertible, filepath, parsec, stm, tasty, tasty-hunit, tasty-quickcheck, template-haskell, yeshql-core, yeshql-hdbc
Files
- LICENSE +20/−0
- src/Database/YeshQL/HDBC.hs +151/−0
- src/Database/YeshQL/HDBC/SqlRow/Class.hs +104/−0
- src/Database/YeshQL/HDBC/SqlRow/TH.hs +129/−0
- tests/Database/HDBC/Mock.hs +235/−0
- tests/Database/YeshQL/HDBC/SimulationTests.hs +422/−0
- tests/fixtures/getUser.sql +3/−0
- tests/fixtures/getUserNamed.sql +3/−0
- tests/fixtures/multiQueries.sql +7/−0
- tests/tests.hs +12/−0
- yeshql-hdbc.cabal +52/−0
+ LICENSE view
@@ -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.
+ src/Database/YeshQL/HDBC.hs view
@@ -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 <tdammers@gmail.com>+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
+ src/Database/YeshQL/HDBC/SqlRow/Class.hs view
@@ -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
+ src/Database/YeshQL/HDBC/SqlRow/TH.hs view
@@ -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
+ tests/Database/HDBC/Mock.hs view
@@ -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+ }
+ tests/Database/YeshQL/HDBC/SimulationTests.hs view
@@ -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
+ tests/fixtures/getUser.sql view
@@ -0,0 +1,3 @@+-- :: [(Int, String)]+-- :userID :: Int+SELECT id, username FROM users WHERE id = :userID
+ tests/fixtures/getUserNamed.sql view
@@ -0,0 +1,3 @@+-- name:getUserA :: [(Int, String)]+-- :userID :: Int+SELECT id, username FROM users WHERE id = :userID
+ tests/fixtures/multiQueries.sql view
@@ -0,0 +1,7 @@+-- :: rowcount Integer+BLAH+;;;+-- name: multiQueriesNamed :: rowcount Integer+PIZZA+;;;+OLIVES
+ tests/tests.hs view
@@ -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+ ]
+ yeshql-hdbc.cabal view
@@ -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