yeshql 1.0.0.0 → 1.0.0.1
raw patch · 3 files changed
+509/−1 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- tests/Database/HDBC/Mock.hs +235/−0
- tests/Database/YeshQL/SimulationTests.hs +271/−0
- yeshql.cabal +3/−1
+ 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/SimulationTests.hs view
@@ -0,0 +1,271 @@+{-#LANGUAGE QuasiQuotes #-}+{-#LANGUAGE RankNTypes #-}+module Database.YeshQL.SimulationTests+( tests+)+where++import Test.Tasty+import Test.Tasty.HUnit+import Database.HDBC+import Database.HDBC.Mock+import Database.YeshQL+import System.IO+import Data.Char+import Data.List (dropWhile, dropWhileEnd)++tests =+ [ testSimpleSelect+ , testParametrizedSelect+ , testSingleInsert+ , 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+ }+ ]++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+ }+ ]++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
yeshql.cabal view
@@ -1,5 +1,5 @@ name: yeshql-version: 1.0.0.0+version: 1.0.0.1 synopsis: YesQL-style SQL database abstraction description: Use quasi-quotations to write SQL in SQL, while at the same time adding type annotations to turn them into well-typed Haskell@@ -37,4 +37,6 @@ , HDBC hs-source-dirs: tests main-is: tests.hs+ other-modules: Database.YeshQL.SimulationTests+ , Database.HDBC.Mock default-language: Haskell2010