yeshql-postgresql-simple (empty) → 4.1.0.0
raw patch · 8 files changed
+534/−0 lines, 8 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, convertible, filepath, parsec, postgresql-simple, stm, tasty, tasty-hunit, tasty-quickcheck, template-haskell, yeshql-core, yeshql-postgresql-simple
Files
- LICENSE +20/−0
- src/Database/YeshQL/PostgreSQL.hs +184/−0
- tests/Database/YeshQL/PostgreSQL/Tests.hs +231/−0
- tests/fixtures/getUser.sql +3/−0
- tests/fixtures/getUserNamed.sql +3/−0
- tests/fixtures/multiQueries.sql +7/−0
- tests/tests.hs +36/−0
- yeshql-postgresql-simple.cabal +50/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015-2017 Tobias Dammers and contributors++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/PostgreSQL.hs view
@@ -0,0 +1,184 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE CPP #-}+{-#LANGUAGE RankNTypes #-}+{-#LANGUAGE FlexibleInstances #-}+{-|+Module: Database.YeshQL.PostgreSQL+Description: Turn SQL queries into type-safe functions.+Copyright: (c) 2015-2017 Tobias Dammers and contributors+Maintainer: Tobias Dammers <tdammers@gmail.com>+Stability: experimental+License: MIT++ -}+module Database.YeshQL.PostgreSQL+(+-- * Quasi-quoters that take strings+ yesh, yesh1+-- * Quasi-quoters that take filenames+, yeshFile, yesh1File+-- * Query parsers+, parseQuery+, parseQueries+-- * AST+, ParsedQuery (..)+)+where++import Data.String+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 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 qualified Database.PostgreSQL.Simple as PostgreSQL++import Database.YeshQL.Parser+import Database.YeshQL.Util+import Database.YeshQL.Backend++yesh :: Yesh a => a+yesh = yeshWith pgBackend++yesh1 :: Yesh a => a+yesh1 = yesh1With pgBackend++yeshFile :: YeshFile a => a+yeshFile = yeshFileWith pgBackend++yesh1File :: YeshFile a => a+yesh1File = yesh1FileWith pgBackend++pgBackend :: YeshBackend+pgBackend =+ YeshBackend+ { ybNames = pqNames+ , ybMkQueryBody = mkQueryBody+ }++pgQueryType :: ParsedQuery -> TypeQ+pgQueryType query =+ [t|PostgreSQL.Connection ->+ $(foldr+ (\a b -> [t| $a -> $b |])+ [t| 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 = "conn" : pqParamNames query+ 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:[]) -> [|id|]+ ReturnTuple _ xs -> [|id|]+ ReturnRecord _ x -> [|id|]+ queryFunc = case pqReturnType query of+ ReturnRowCount _ ->+ [| \qstr params conn -> fmap fromIntegral (PostgreSQL.execute conn (fromString qstr) params) |]+ ReturnTuple Many tys ->+ case tys of+ [t] -> [| \qstr params conn -> map fromOnly <$> PostgreSQL.query conn (fromString qstr) params |]+ _ -> [| \qstr params conn -> PostgreSQL.query conn (fromString qstr) params |]+ ReturnTuple One tys ->+ case tys of+ [t] -> [| \qstr params conn -> fmap (fmap fromOnly . headMay) (PostgreSQL.query conn (fromString qstr) params) |]+ _ -> [| \qstr params conn -> fmap headMay (PostgreSQL.query conn (fromString qstr) params) |]+ ReturnRecord Many _ ->+ [| \qstr params conn -> PostgreSQL.query conn (fromString qstr) params |]+ ReturnRecord One _ ->+ [| \qstr params conn -> fmap headMay (PostgreSQL.query conn (fromString qstr) params) |]+ rawQueryFunc = [| \qstr conn -> () <$ execute_ conn (fromString qstr) |]+ if pqDDL query+ then+ rawQueryFunc+ `appE` (litE . stringL . pqQueryString $ query)+ `appE` (varE . mkName $ "conn")+ else+ queryFunc+ `appE` (litE . stringL . pqQueryString $ query)+ `appE` (case map paramArg $ pqParamsRaw query of+ [] -> [| () |]+ [p] -> conE 'PostgreSQL.Only `appE` p+ ps -> tupE ps)+ `appE` (varE . mkName $ "conn")++ where+ paramArg :: ExtractedParam -> ExpQ+ paramArg (ExtractedParam n ps _) =+ foldl1 (flip appE) (map (varE . mkName) (n:ps))
+ tests/Database/YeshQL/PostgreSQL/Tests.hs view
@@ -0,0 +1,231 @@+{-#LANGUAGE QuasiQuotes #-}+{-#LANGUAGE RankNTypes #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE TemplateHaskell #-}+module Database.YeshQL.PostgreSQL.Tests+( tests+)+where++import Test.Tasty+import Test.Tasty.HUnit+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow+import Database.YeshQL.PostgreSQL+import System.IO+import Data.Char+import Data.List (dropWhile, dropWhileEnd)++data User = User+ { userID :: Int+ , userName :: String+ } deriving (Show, Eq)++instance FromRow User where+ fromRow = User <$> field <*> field++data Person = Person+ { personName :: String+ , personEmail :: String+ } deriving (Show, Eq)++data UserData = UserData+ { user :: User+ , person :: Person+ } deriving (Show, Eq)++instance FromRow UserData where+ fromRow =+ UserData+ <$> (User <$> field <*> field)+ <*> (Person <$> field <*> field)++tests conn =+ map+ ($ conn)+ [ testSimpleSelect+ , testSimpleSelectStr+ , testParametrizedSelect+ , testSingleInsert+ , testRecordReturn+ , testRecordReturnComplex+ , testRecordReturnExcessive+ , testTupleReturnMany+ , testRecordReturnMany+ , testRecordParams+ , testUpdateReturnRowCount+ , testMultiQuery+ , testQueryFromFile+ , testQueryFromFileAutoName+ , testDDL+ ]++testSimpleSelect :: Connection -> TestTree+testSimpleSelect conn = testCase "Simple SELECT" $ do+ results <- [yesh|+ -- name:getUserByName :: (String)+ SELECT username FROM users|] conn+ return ()++testSimpleSelectStr :: Connection -> TestTree+testSimpleSelectStr conn = testCase "Simple SELECT (expr by string)" $ do+ results <- $(yesh $ unlines+ [ "-- name:getUserByName :: (String)"+ , "SELECT username FROM users"+ ]) conn+ return ()++testParametrizedSelect :: Connection -> TestTree+testParametrizedSelect conn = testCase "Parametrized SELECT" $ do+ actual <- [yesh|+ -- name:getUserByName :: (Integer, String)+ -- :username :: String+ SELECT id, username FROM users WHERE username = :username LIMIT 1|] conn "billy"+ let expected :: Maybe (Integer, String)+ expected = Just (1, "billy")+ assertEqual "" expected actual++testRecordReturn :: Connection -> TestTree+testRecordReturn conn = testCase "Return record from SELECT" $ do+ actual <- [yesh|+ -- name:getUserByName :: User+ -- :username :: String+ SELECT id, username FROM users WHERE username = :username LIMIT 1|]+ conn+ "billy"+ let expected :: Maybe User+ expected = Just $ User 1 "billy"+ assertEqual "" expected actual++testRecordReturnComplex :: Connection -> TestTree+testRecordReturnComplex conn = testCase "Return record from SELECT" $ do+ actual <- [yesh|+ -- name:getUserByName :: UserData+ -- :username :: String+ SELECT id, username, person_name, email FROM users WHERE username = :username and id = 1|]+ conn+ "billy"+ let expected :: Maybe UserData+ expected = Just $ UserData (User 1 "billy") (Person "Billy" "billy@example.org")+ assertEqual "" expected actual++testRecordReturnExcessive :: Connection -> TestTree+testRecordReturnExcessive conn = testCase "Return record from SELECT (extra values ignored)" $ do+ actual <- [yesh|+ -- name:getUserByName :: User+ -- :username :: String+ SELECT id, username FROM users WHERE username = :username LIMIT 1|]+ conn+ "billy"+ let expected :: Maybe User+ expected = Just $ User 1 "billy"+ assertEqual "" expected actual++testTupleReturnMany :: Connection -> TestTree+testTupleReturnMany conn = testCase "Return a list of single-element tuples" $ do+ actual <- [yesh|+ -- name:getUsers :: [(String)]+ select username from Users|] conn+ let expected = ["billy", "billy"]+ assertEqual "" expected actual++testRecordReturnMany :: Connection -> TestTree+testRecordReturnMany conn = testCase "Return a list of records from SELECT" $ do+ actual <- [yesh|+ -- name:getUsers :: [User]+ select id, username from Users|] conn+ let expected = [User 1 "billy", User 2 "billy"]+ assertEqual "" expected actual++testRecordParams :: Connection -> TestTree+testRecordParams conn = testCase "Pass records as params" $ do+ actual <- [yesh|+ -- name:getUserByName :: User+ -- :user :: User+ SELECT id, username FROM users WHERE username = :user.userName.reverse LIMIT 1|]+ conn+ (User 10 "yllib")+ let expected :: Maybe User+ expected = Just $ User 1 "billy"+ assertEqual "" expected actual++testSingleInsert :: Connection -> TestTree+testSingleInsert conn = testCase "Single INSERT" $ do+ actual <- [yesh|+ -- name:createUser :: (Integer)+ -- :username :: String+ INSERT INTO users (username) VALUES (:username) RETURNING id|] conn "billy"+ let expected :: Maybe Integer+ expected = Just 2+ assertEqual "" expected actual++testUpdateReturnRowCount :: Connection -> TestTree+testUpdateReturnRowCount conn = testCase "UPDATE, get row count" $ do+ actual <- [yesh|+ -- name:renameUser :: rowcount Integer+ -- :oldName :: String+ -- :newName :: String+ UPDATE users SET username = :oldName WHERE username = :newName AND username <> :oldName|]+ conn "tony" "billy"+ let expected :: Integer+ expected = 2+ assertEqual "" expected actual++[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 :: Connection -> TestTree+testMultiQuery conn = testCase "Define multiple queries in one QQ inside a where" $ do+ userID <- maybe (fail "User Not Found") return =<< findUser conn "tony"+ rowCount <- setUserName conn userID "billy"+ assertEqual "" rowCount 1++testQueryFromFile :: Connection -> TestTree+testQueryFromFile conn = testCase "Query loaded from fixture file" $ do+ [(userID, username)] <- [yesh1File|tests/fixtures/getUserNamed.sql|] conn 1+ assertEqual "" userID 1+ assertEqual "" username "billy"++[yesh1File|tests/fixtures/getUser.sql|]++testQueryFromFileAutoName :: Connection -> TestTree+testQueryFromFileAutoName conn = testCase "Query loaded from fixture file, deriving query name from filename" $ do+ [(userID, username)] <- getUser conn 1+ assertEqual "" userID 1+ assertEqual "" username "billy"++[yeshFile|tests/fixtures/multiQueries.sql|]++testManyQueriesFromFileAutoName :: Connection -> TestTree+testManyQueriesFromFileAutoName conn = testCase "Many queries from fixture file, auto-naming some" $ do+ count0 <- multiQueries_0 conn+ count1 <- multiQueriesNamed conn+ count2 <- multiQueries_2 conn+ assertEqual "" count0 1+ assertEqual "" count1 2+ assertEqual "" count2 3++testDDL :: Connection -> TestTree+testDDL conn = testCase "typical DDL statement sequence" $ do+ [yesh1|+ -- @ddl+ CREATE TABLE users_tmp+ ( id INTEGER+ , username TEXT+ );+ CREATE TABLE pages+ ( id INTEGER+ , owner_id INTEGER+ , title TEXT+ , body TEXT+ , FOREIGN KEY (owner_id) REFERENCES users (id)+ );+ |] conn
+ 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:getUser :: [(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,36 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Exception+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as ByteString+import Database.PostgreSQL.Simple+import qualified Database.YeshQL.PostgreSQL.Tests as Tests+import System.Environment+import System.Exit+import System.IO+import Test.Tasty++main :: IO ()+main = do+ mConnString <- lookupEnv "YESHQL_POSTGRESQL_CONNSTRING"+ case mConnString of+ Nothing -> do+ hPutStrLn stderr "Please set the 'YESHQL_POSTGRESQL_CONNSTRING' to the PostgreSQL connection string"+ exitFailure+ Just connString -> withConn (ByteString.pack connString) (defaultMain . allTests)+ where+ allTests conn = testGroup "All Tests" (Tests.tests conn)++withConn :: ByteString -> (Connection -> IO a) -> IO a+withConn connString f =+ bracket (connectPostgreSQL connString) close $ \c ->+ bracket_ (begin c) (rollback c) $ do+ initializeDb c+ f c++initializeDb :: Connection -> IO ()+initializeDb c = do+ execute_ c "create table users (id serial primary key, username text, person_name text, email text);"+ execute_ c "insert into users (username, person_name, email) values ('billy', 'Billy', 'billy@example.org');"+ pure ()
+ yeshql-postgresql-simple.cabal view
@@ -0,0 +1,50 @@+name: yeshql-postgresql-simple+version: 4.1.0.0+synopsis: YesQL-style SQL database abstraction (postgresql-simple 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.PostgreSQL+ -- other-extensions:+ build-depends: base >=4.6 && <5.0+ , yeshql-core >= 4.0 && <5.0+ , containers >= 0.5 && < 1.0+ , filepath+ , parsec >= 3.0 && <4.0+ , postgresql-simple >= 0.5 && < 0.6+ , 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+ , bytestring+ , containers+ , postgresql-simple+ , stm+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , yeshql-postgresql-simple+ hs-source-dirs: tests+ main-is: tests.hs+ other-modules: Database.YeshQL.PostgreSQL.Tests+ default-language: Haskell2010