diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -56,3 +56,17 @@ YeshQL is Free Software and provided as-is. Please see the enclosed LICENSE file for details. + +## Legacy / Backwards-Compatibility Notice + +**Note** that the `yeshql` package, starting with the 4.1 release, is now +merely a wrapper around `yeshql-core` and `yeshql-hdbc`, re-exporting what is +hopefully close enough to the original `yeshql` API to be somewhat compatible. + +This is because starting with this release, `yeshql` has been split up into a +frontend, which takes care of query parsing and the whole TemplateHaskell +machinery, and several backends - at the time of writing, these are +`yeshql-hdbc`, which uses HDBC just like the original `yeshql` package, and +`yeshql-postgresql-simpel`, which uses `postgresql-simple`. With this +architecture, it is possible to add more backends without affecting the +frontend or any of the other backends. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/src/Database/YeshQL.hs b/src/Database/YeshQL.hs --- a/src/Database/YeshQL.hs +++ b/src/Database/YeshQL.hs @@ -245,9 +245,6 @@ Yesh (..) -- * Quasi-quoters that take filenames , YeshFile (..) --- * Low-level generators in the 'Q' monad -, mkQueryDecs -, mkQueryExp -- * Query parsers , parseQuery , parseQueries @@ -256,361 +253,8 @@ ) 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.Core +import Database.YeshQL.Backend import Database.YeshQL.Parser -import Database.YeshQL.SqlRow.Class - -headMay :: [a] -> Maybe a -headMay [] = Nothing -headMay (x:_) = Just x - -nthIdent :: Int -> String -nthIdent i - | i < 26 = [chr (ord 'a' + i)] - | otherwise = let (j, k) = divMod i 26 - in nthIdent j ++ nthIdent k - --- | This typeclass is needed to allow 'yesh' and 'yesh1' to be used --- interchangeably as quasi-quoters and TH functions. Because the intended --- instances are @String -> Q [Dec]@ and @QuasiQuoter@, it is unfortunately not --- possible to give the methods more obvious signatures like @String -> a@. -class Yesh a where - -- | Generate top-level declarations or expressions for several SQL - -- queries. If used at the top level (i.e., generating declarations), all - -- queries in the definitions must be named, and 'yesh' will generate a - -- separate set of functions for each. If used in an expression context, - -- the current behavior is somewhat undesirable, namely sequencing the - -- queries using '>>'. - -- - -- Future versions will most likely change this to create a tuple of query - -- expressions instead, such that you can write something like: - -- - -- @ - -- let (createUser, getUser, updateUser, deleteUser) = [yesh| - -- -- name:createUser :: (Integer) - -- -- :username :: String - -- INSERT INTO users (username) VALUES (:username) RETURNING id; - -- -- name:getUser :: (Integer, String) - -- -- :userID :: Integer - -- SELECT id, username FROM users WHERE id = :userID; - -- -- name:updateUser :: Integer - -- -- :userID :: Integer - -- -- :username :: String - -- UPDATE users SET username = :username WHERE id = :userID; - -- -- name:deleteUser :: Integer - -- -- :userID :: Integer - -- DELETE FROM users WHERE id = :userID LIMIT 1; - -- |] - -- @ - - yesh :: a - -- | Generate a top-level declaration or an expression for a single SQL - -- query. If used at the top level (i.e., generating a declaration), the - -- query definition must specify a query name. - yesh1 :: a - --- | This typeclass is needed to allow 'yeshFile' and 'yesh1File' to be used --- interchangeably as quasi-quoters and TH functions. --- Because the intended instances are @FilePath -> Q [Dec]@ and @QuasiQuoter@, --- it is unfortunately not possible to give the methods more obvious signatures --- like @FilePath -> a@. -class YeshFile a where - -- | Generate multiple query definitions or expressions from an external - -- file. Query name derivation works exactly like for 'yesh1File', except - -- that an underscore and a 0-based query index are appended to - -- disambiguate queries from the same file. - -- - -- In an expression context, the same caveats apply as for 'yesh', i.e., to - -- generate expressions, you will almost certainly want 'yesh1File', not - -- 'yeshFile'. - yeshFile :: a - - -- | Generate one query definition or expression from an external file. In - -- a declaration context, the query name will be derived from the filename - -- unless the query contains an explicit name. Query name derivation works - -- as follows: - -- - -- 1. Take only the basename (stripping off the directories and extension) - -- 2. Remove all non-alphabetic characters from the beginning of the name - -- 3. Remove all non-alphanumeric characters from the name - -- 4. Lower-case the first character. - -- - -- Note that since there is always a filename to derive the query name - -- from, explicitly defining a query name is only necessary when you want - -- it to differ from the filename; however, making it explicit anyway is - -- probably a good idea. - yesh1File :: a - -instance Yesh (String -> Q [Dec]) where - yesh1 = withParsedQuery mkQueryDecs - yesh = withParsedQueries mkQueryDecsMulti - -instance YeshFile (FilePath -> Q [Dec]) where - yesh1File = withParsedQueryFile mkQueryDecs - yeshFile = withParsedQueriesFile mkQueryDecsMulti - -instance Yesh (String -> Q Exp) where - yesh1 = withParsedQuery mkQueryExp - yesh = withParsedQueries mkQueryExpMulti - -instance YeshFile (FilePath -> Q Exp) where - yesh1File = withParsedQueryFile mkQueryExp - yeshFile = withParsedQueriesFile mkQueryExpMulti - -instance Yesh QuasiQuoter where - yesh = QuasiQuoter - { quoteDec = yesh - , quoteExp = yesh - , quoteType = error "YeshQL does not generate types" - , quotePat = error "YeshQL does not generate patterns" - } - yesh1 = QuasiQuoter - { quoteDec = yesh1 - , quoteExp = yesh1 - , quoteType = error "YeshQL does not generate types" - , quotePat = error "YeshQL does not generate patterns" - } - -instance YeshFile QuasiQuoter where - yeshFile = QuasiQuoter - { quoteDec = yeshFile - , quoteExp = yeshFile - , quoteType = error "YeshFileQL does not generate types" - , quotePat = error "YeshFileQL does not generate patterns" - } - yesh1File = QuasiQuoter - { quoteDec = yesh1File - , quoteExp = yesh1File - , quoteType = error "YeshFileQL does not generate types" - , quotePat = error "YeshFileQL does not generate patterns" - } - -queryName :: String -> String -> Name -queryName prefix = mkName . queryIdentifier prefix - -queryIdentifier :: String -> String -> String -queryIdentifier "" basename = - lcfirst . makeValidIdentifier . takeBaseName $ basename -queryIdentifier prefix basename = - (prefix ++) . ucfirst . makeValidIdentifier . takeBaseName $ basename - -ucfirst :: String -> String -ucfirst "" = "" -ucfirst (x:xs) = toUpper x:xs - -lcfirst :: String -> String -lcfirst "" = "" -lcfirst (x:xs) = toLower x:xs - -withParsedQuery :: (ParsedQuery -> Q a) -> String -> Q a -withParsedQuery = withParsed parseQuery - -withParsedQueries :: ([ParsedQuery] -> Q a) -> String -> Q a -withParsedQueries = withParsed parseQueries - -withParsedQueryFile :: (ParsedQuery -> Q a) -> FilePath -> Q a -withParsedQueryFile p fn = - withParsedFile - (parseQueryN fn) - (p . nameQuery (queryIdentifier "" fn)) - fn - -withParsedQueriesFile :: ([ParsedQuery] -> Q a) -> FilePath -> Q a -withParsedQueriesFile p fn = - withParsedFile - (parseQueriesN fn) - (p . nameQueries (queryIdentifier "" fn)) - fn - -nameQuery :: String -> ParsedQuery -> ParsedQuery -nameQuery qname pq - | null (pqQueryName pq) = pq { pqQueryName = qname } - | otherwise = pq - -nameQueries :: String -> [ParsedQuery] -> [ParsedQuery] -nameQueries basename queries = - zipWith nameQuery queryNames queries - where - queryNames = [ basename ++ "_" ++ show i | i <- [0..] ] - -makeValidIdentifier :: String -> String -makeValidIdentifier = - filter isAlphaNum . - dropWhile (not . isAlpha) - -withParsed :: (Monad m, Show e) => (s -> Either e a) -> (a -> m b) -> s -> m b -withParsed p a src = do - let parseResult = p src - arg <- case parseResult of - Left e -> fail . show $ e - Right x -> return x - a arg - --- | Monad in which we can perform IO and tag dependencies. Mostly needed --- because we cannot easily make a 'MonadIO' instance for 'Q', and also --- because we want to avoid a dependency on mtl or transformers. For --- convenience, we also pull 'addDependentFile' into this typeclass. -class MonadPerformIO m where - performIO :: IO a -> m a - addDependentFile :: FilePath -> m () - -instance MonadPerformIO IO where - performIO = id - -- in IO, don't try to track dependencies - addDependentFile = const $ return () - -instance MonadPerformIO Q where - performIO = runIO -#if MIN_VERSION_template_haskell(2,7,0) - -- modern GHC: proper implementation - addDependentFile = qAddDependentFile -#else - -- ancient GHC: ignore dependency - addDependentFile = const $ return () -#endif - -withParsedFile :: (MonadPerformIO m, Monad m, Show e) => (String -> Either e a) -> (a -> m b) -> FilePath -> m b -withParsedFile p a filename = - addDependentFile filename >> - performIO (readFile filename) >>= - withParsed p a - -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|] - -mkQueryDecsMulti :: [ParsedQuery] -> Q [Dec] -mkQueryDecsMulti queries = concat <$> mapM mkQueryDecs queries - --- TODO: instead of sequencing the queries, put them in a tuple. -mkQueryExpMulti :: [ParsedQuery] -> Q Exp -mkQueryExpMulti queries = - foldl1 (\a b -> VarE '(>>) `AppE` a `AppE` b) <$> mapM mkQueryExp queries - -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) - -mkQueryDecs :: ParsedQuery -> Q [Dec] -mkQueryDecs query = do - let (argNames, patterns, funName, queryType) = pqNames query - sRun <- sigD (mkName . lcfirst $ funName) queryType - fRun <- funD (mkName . lcfirst $ funName) - [ clause - (map varP argNames) - (normalB . mkQueryBody $ query) - [] - ] - sDescribe <- sigD (queryName "describe" funName) [t|String|] - fDescribe <- funD (queryName "describe" funName) - [ clause - [] - (normalB . litE . stringL . pqQueryString $ query) - [] - ] - sDocument <- sigD (queryName "doc" funName) [t|String|] - fDocument <- funD (queryName "doc" funName) - [ clause - [] - (normalB . litE . stringL . pqDocComment $ query) - [] - ] - return [sRun, fRun, sDescribe, fDescribe, sDocument, fDocument] - -mkQueryExp :: ParsedQuery -> Q Exp -mkQueryExp query = do - let (argNames, patterns, funName, queryType) = pqNames query - sigE - (lamE patterns (mkQueryBody query)) - 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 +import Database.YeshQL.HDBC +import Database.YeshQL.HDBC.SqlRow.Class diff --git a/src/Database/YeshQL/Parser.hs b/src/Database/YeshQL/Parser.hs deleted file mode 100644 --- a/src/Database/YeshQL/Parser.hs +++ /dev/null @@ -1,340 +0,0 @@ -module Database.YeshQL.Parser -( parseQuery -, parseQueries -, parseQueryN -, parseQueriesN -, ParsedQuery (..) -, ParsedType (..) -, ParsedReturnType (..) -, ExtractedParam (..) -, OneOrMany (..) -, pqTypeFor -) -where - -import Text.Parsec -import Control.Applicative ( (<$>), (<*>) ) - -import qualified Data.Map.Strict as Map -import Data.Map (Map) - -import Data.List (foldl', nub) -import Data.Maybe (catMaybes, fromMaybe) - -data ParsedType = PlainType String - | MaybeType String - | AutoType - deriving Show - -data OneOrMany = One | Many - deriving (Show, Eq, Enum, Ord) - -data ParsedReturnType = ReturnRowCount ParsedType - | ReturnTuple OneOrMany [ParsedType] - | ReturnRecord OneOrMany ParsedType - deriving (Show) - -data ExtractedParam = - ExtractedParam - { paramName :: String - , paramProjections :: [String] - , paramType :: ParsedType - } - deriving (Show) - -data ParsedQuery = - ParsedQuery - { pqQueryName :: String - , pqQueryString :: String - , pqParamsRaw :: [ExtractedParam] - , pqParamNames :: [String] - , pqParamTypes :: Map String ParsedType - , pqReturnType :: ParsedReturnType - , pqDocComment :: String - , pqDDL :: Bool - } - deriving (Show) - -pqTypeFor :: ParsedQuery -> String -> Maybe ParsedType -pqTypeFor q pname = Map.lookup pname (pqParamTypes q) - -parsedQuery :: String - -> String - -> [ExtractedParam] - -> [ExtractedParam] - -> ParsedReturnType - -> String - -> Bool - -> ParsedQuery -parsedQuery queryName - queryString - paramsRaw - paramsExtra - returnType - docComment - isDDL = - ParsedQuery - queryName - queryString - paramsRaw - (extractParamNames (paramsExtra ++ paramsRaw)) - (extractParamTypeMap (paramsExtra ++ paramsRaw)) - returnType - docComment - isDDL - -extractParamNames :: [ExtractedParam] -> [String] -extractParamNames xs = - nub . map paramName $ xs - -extractParamTypeMap :: [ExtractedParam] -> Map String ParsedType -extractParamTypeMap = foldl' applyItem Map.empty - where - applyItem :: Map String ParsedType -> ExtractedParam -> Map String ParsedType - applyItem m (ExtractedParam n _ t) = - let tc = Map.lookup n m - in case (tc, t) of - (Nothing, AutoType) -> m - (Nothing, t) -> Map.insert n t m - (Just AutoType, AutoType) -> m - (Just AutoType, t) -> Map.insert n t m - (Just t', AutoType) -> m - (Just t', t) -> error $ "Inconsistent types found for parameter '" ++ n ++ "': '" ++ show t' ++ "' vs. '" ++ show t ++ "'" - -data ParsedItem = ParsedLiteral String - | ParsedParam String ParsedType - | ParsedParamAttrib String [String] ParsedType - | ParsedComment String - | ParsedAnnotation Annotation - deriving (Show) - -data Annotation = - DDLAnnotation - deriving (Show) - -extractParsedQuery :: [ParsedItem] -> String -extractParsedQuery = concat . map extractItem - where - extractItem :: ParsedItem -> String - extractItem (ParsedLiteral str) = str - extractItem (ParsedComment _) = "" - extractItem (ParsedParam _ _) = "?" - extractItem (ParsedParamAttrib _ _ _) = "?" - -extractParsedParams :: [ParsedItem] -> [ExtractedParam] -extractParsedParams = catMaybes . map extractItem - where - extractItem :: ParsedItem -> Maybe ExtractedParam - extractItem (ParsedParam n t) = Just $ ExtractedParam n [] t - extractItem (ParsedParamAttrib n p t) = Just $ ExtractedParam n p t - extractItem _ = Nothing - -extractDocComment :: [ParsedItem] -> String -extractDocComment = unlines . catMaybes . map extractItem - where - extractItem :: ParsedItem -> Maybe String - extractItem (ParsedComment str) = Just str - extractItem _ = Nothing - -extractIsDDL :: [ParsedItem] -> Bool -extractIsDDL items = - not . null $ [ undefined | ParsedAnnotation DDLAnnotation <- items ] - -parseQueryN :: String -> String -> Either ParseError ParsedQuery -parseQueryN fn src = - runParser mainP () fn src - -parseQuery :: String -> Either ParseError ParsedQuery -parseQuery = parseQueryN "" - -parseQueriesN :: String -> String -> Either ParseError [ParsedQuery] -parseQueriesN fn src = - runParser multiP () fn src - -parseQueries :: String -> Either ParseError [ParsedQuery] -parseQueries = parseQueriesN "" - -mainP :: Parsec String () ParsedQuery -mainP = do - q <- queryP - eof - return q - -multiP :: Parsec String () [ParsedQuery] -multiP = do - fmap catMaybes $ - sepBy queryMayP sepP - where - sepP :: Parsec String () () - sepP = try (spaces >> string ";;;" >> spaces) - queryMayP :: Parsec String () (Maybe ParsedQuery) - queryMayP = do - spaces - fmap Just queryP <|> (eof >> return Nothing) "SQL query" - -queryP :: Parsec String () ParsedQuery -queryP = do - spaces - (qn, retType) <- option ("", ReturnRowCount (PlainType "Integer")) $ nameDeclP <|> namelessDeclP - extraItems <- many (try annotationP <|> paramDeclP <|> commentP) - items <- many (try itemP <|> try commentP) - return $ parsedQuery - qn - (extractParsedQuery items) - (extractParsedParams items) - (extractParsedParams extraItems) - retType - (extractDocComment (extraItems ++ items)) - (extractIsDDL (extraItems ++ items)) - -nameDeclP :: Parsec String () (String, ParsedReturnType) -nameDeclP = do - try (whitespaceP >> string "--" >> whitespaceP >> string "name" >> whitespaceP >> char ':') - whitespaceP - qn <- identifierP - whitespaceP - retType <- option (ReturnRowCount (PlainType "Integer")) (try (string "::" >> whitespaceP >> returnTypeP)) - whitespaceP - newlineP - return (qn, retType) - -namelessDeclP :: Parsec String () (String, ParsedReturnType) -namelessDeclP = do - try (whitespaceP >> string "--" >> whitespaceP >> string "::" >> whitespaceP) - retType <- returnTypeP - whitespaceP - newlineP - return ("", retType) - -identifierP :: Parsec String () String -identifierP = - (:) <$> leadCharP <*> many tailCharP - where - leadCharP = oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ "_" - tailCharP = oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" - -returnTypeP :: Parsec String () ParsedReturnType -returnTypeP = returnTypeRowcountP <|> returnTypeMultiP <|> returnTypeSingleP - -returnTypeRowcountP :: Parsec String () ParsedReturnType -returnTypeRowcountP = do - try (string "rowcount") - whitespaceP - ReturnRowCount <$> typeP - -setNumerus :: OneOrMany -> ParsedReturnType -> ParsedReturnType -setNumerus _ (ReturnRowCount t) = ReturnRowCount t -setNumerus numerus (ReturnTuple _ x) = ReturnTuple numerus x -setNumerus numerus (ReturnRecord _ x) = ReturnRecord numerus x - -returnTypeMultiP :: Parsec String () ParsedReturnType -returnTypeMultiP = - setNumerus Many <$> between - (char '[' >> whitespaceP) - (char ']' >> whitespaceP) - returnTypeRowP - -returnTypeSingleP :: Parsec String () ParsedReturnType -returnTypeSingleP = - setNumerus One <$> returnTypeRowP - -returnTypeRowP :: Parsec String () ParsedReturnType -returnTypeRowP = - fmap (ReturnTuple One) returnTypeTupleP <|> - fmap (ReturnRecord One) typeP - -returnTypeTupleP :: Parsec String () [ParsedType] -returnTypeTupleP = - between - (char '(' >> whitespaceP) - (char ')' >> whitespaceP) - (sepBy (between whitespaceP whitespaceP typeP) (char ',')) - - -typeP :: Parsec String () ParsedType -typeP = do - name <- identifierP - option (PlainType name) $ do - char '?' - return $ MaybeType name - -itemP :: Parsec String () ParsedItem -itemP = paramP <|> quotedP <|> literalP <|> semicolonP - -semicolonP :: Parsec String () ParsedItem -semicolonP = try $ do - char ';' - notFollowedBy $ char ';' - return $ ParsedLiteral ";" - -annotationP :: Parsec String () ParsedItem -annotationP = do - try $ (whitespaceP >> string "--" >> whitespaceP >> char '@') - ParsedAnnotation <$> ddlAnnotationP - -ddlAnnotationP :: Parsec String () Annotation -ddlAnnotationP = do - string "ddl" - whitespaceP - newlineP - return DDLAnnotation - -paramDeclP :: Parsec String () ParsedItem -paramDeclP = do - try $ (whitespaceP >> string "--" >> whitespaceP >> char ':') - name <- identifierP - whitespaceP - t <- option AutoType $ do - string "::" - whitespaceP *> typeP <* whitespaceP - newlineP - return $ ParsedParam name t - -projectionP :: Parsec String () String -projectionP = char '.' *> identifierP - -commentP :: Parsec String () ParsedItem -commentP = do - try (whitespaceP >> string "--") - whitespaceP - ParsedComment <$> manyTill (noneOf " \t\n;") newlineP - -paramP :: Parsec String () ParsedItem -paramP = do - char ':' - pname <- identifierP - projections <- many projectionP - ptype <- option AutoType $ do - string "::" - typeP - if null projections - then return $ ParsedParam pname ptype - else return $ ParsedParamAttrib pname projections ptype - -quotedP :: Parsec String () ParsedItem -quotedP = do - char '\'' - contents <- many (noneOf "'") - char '\'' - return . ParsedLiteral . ('\'':) . (++ "'") $ contents - -literalP :: Parsec String () ParsedItem -literalP = ParsedLiteral <$> many1 (noneOf ":';") - -whitespaceP :: Parsec String () () -whitespaceP = do - many (oneOf " \t\r") - return () - -whitespace1P :: Parsec String () () -whitespace1P = do - many1 (oneOf " \t\r") - return () - -ignore :: Parsec s u a -> Parsec s u () -ignore x = x >> return () - -newlineP :: Parsec String () () -newlineP = do - (ignore $ char '\n') <|> (ignore . try . string $ ";;") - return () diff --git a/src/Database/YeshQL/SqlRow/Class.hs b/src/Database/YeshQL/SqlRow/Class.hs deleted file mode 100644 --- a/src/Database/YeshQL/SqlRow/Class.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-#LANGUAGE OverloadedStrings #-} -{-#LANGUAGE DeriveGeneric #-} -{-#LANGUAGE DeriveFunctor #-} -{-#LANGUAGE GeneralizedNewtypeDeriving #-} -{-#LANGUAGE LambdaCase #-} -{-#LANGUAGE TemplateHaskell #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE FlexibleContexts #-} -module Database.YeshQL.SqlRow.Class -where - -import Database.HDBC -import Data.Convertible (Convertible, prettyConvertError) - -class ToSqlRow a where - toSqlRow :: a -> [SqlValue] - -newtype Parser a = - Parser { runParser :: [SqlValue] -> Either String (a, [SqlValue]) } - deriving (Functor) - -instance Applicative Parser where - pure x = Parser $ \values -> Right (x, values) - (<*>) = parserApply - -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 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) diff --git a/src/Database/YeshQL/SqlRow/TH.hs b/src/Database/YeshQL/SqlRow/TH.hs deleted file mode 100644 --- a/src/Database/YeshQL/SqlRow/TH.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-#LANGUAGE OverloadedStrings #-} -{-#LANGUAGE DeriveGeneric #-} -{-#LANGUAGE TemplateHaskell #-} -{-#LANGUAGE QuasiQuotes #-} -{-#LANGUAGE LambdaCase #-} -{-#LANGUAGE CPP #-} -module Database.YeshQL.SqlRow.TH -( makeSqlRow -) -where - -import Database.YeshQL.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 deleted file mode 100644 --- a/tests/Database/HDBC/Mock.hs +++ /dev/null @@ -1,235 +0,0 @@ --- | 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/SimulationTests.hs b/tests/Database/YeshQL/SimulationTests.hs deleted file mode 100644 --- a/tests/Database/YeshQL/SimulationTests.hs +++ /dev/null @@ -1,422 +0,0 @@ -{-#LANGUAGE QuasiQuotes #-} -{-#LANGUAGE RankNTypes #-} -{-#LANGUAGE LambdaCase #-} -{-#LANGUAGE TemplateHaskell #-} -module Database.YeshQL.SimulationTests -( tests -) -where - -import Test.Tasty -import Test.Tasty.HUnit -import Database.HDBC -import Database.HDBC.Mock -import Database.YeshQL -import Database.YeshQL.SqlRow.Class -import Database.YeshQL.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 deleted file mode 100644 --- a/tests/fixtures/getUser.sql +++ /dev/null @@ -1,3 +0,0 @@ --- :: [(Int, String)] --- :userID :: Int -SELECT id, username FROM users WHERE id = :userID diff --git a/tests/fixtures/getUserNamed.sql b/tests/fixtures/getUserNamed.sql deleted file mode 100644 --- a/tests/fixtures/getUserNamed.sql +++ /dev/null @@ -1,3 +0,0 @@ --- name:getUser :: [(Int, String)] --- :userID :: Int -SELECT id, username FROM users WHERE id = :userID diff --git a/tests/fixtures/multiQueries.sql b/tests/fixtures/multiQueries.sql deleted file mode 100644 --- a/tests/fixtures/multiQueries.sql +++ /dev/null @@ -1,7 +0,0 @@ --- :: rowcount Integer -BLAH -;;; --- name: multiQueriesNamed :: rowcount Integer -PIZZA -;;; -OLIVES diff --git a/tests/tests.hs b/tests/tests.hs deleted file mode 100644 --- a/tests/tests.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-#LANGUAGE TemplateHaskell #-} -{-#LANGUAGE QuasiQuotes #-} -module Main where - -import Test.Tasty -import qualified Database.YeshQL.SimulationTests as SimulationTests - -main = defaultMain allTests - where - allTests = testGroup "All Tests" - [ testGroup "Simulation Tests" SimulationTests.tests - ] diff --git a/yeshql.cabal b/yeshql.cabal --- a/yeshql.cabal +++ b/yeshql.cabal @@ -1,46 +1,30 @@ name: yeshql -version: 3.0.1.3 -synopsis: YesQL-style SQL database abstraction +version: 4.1.0.0 +synopsis: YesQL-style SQL database abstraction (legacy compatibility wrapper) 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-2016 Tobias Dammers +copyright: 2015-2017 Tobias Dammers and contributors category: Database build-type: Simple extra-source-files: README.md - , tests/fixtures/*.sql cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/tdammers/yeshql.git + library exposed-modules: Database.YeshQL - , Database.YeshQL.SqlRow.Class - , Database.YeshQL.SqlRow.TH - other-modules: Database.YeshQL.Parser -- other-extensions: build-depends: base >=4.6 && <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 + , yeshql-core + , yeshql-hdbc hs-source-dirs: src - default-language: Haskell2010 -test-suite tests - type: exitcode-stdio-1.0 - build-depends: base >=4.6 && <5.0 - , yeshql - , stm - , tasty - , tasty-hunit - , tasty-quickcheck - , HDBC - hs-source-dirs: tests - main-is: tests.hs - other-modules: Database.YeshQL.SimulationTests - , Database.HDBC.Mock default-language: Haskell2010