hasql-postgres 0.8.0 → 0.9.0
raw patch · 10 files changed
+394/−324 lines, 10 filesdep +directorydep +doctestdep +filepathdep −HTFdep ~basedep ~base-preludedep ~eitherbuild-type:Customsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: directory, doctest, filepath, hspec
Dependencies removed: HTF
Dependency ranges changed: base, base-prelude, either, hasql, list-t, monad-control
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- Setup.hs +52/−2
- doctest/Main.hs +66/−0
- hasql-postgres.cabal +29/−59
- hspec/Main.hs +238/−0
- library-tests/Hasql/Postgres/TemplateConverterTests.hs +0/−15
- library-tests/Main.hs +0/−10
- library/Hasql/Postgres/Session/ResultProcessing.hs +1/−1
- library/Hasql/Postgres/TemplateConverter.hs +4/−0
- tests/Main.hs +0/−237
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# 0.9.0+* The unit result handler no longer fails on statements, which do produce results+* The dependency on "list-t" got relaxed+* The dependency on "either" got restricted
Setup.hs view
@@ -1,2 +1,52 @@-import Distribution.Simple-main = defaultMain+-- The code is mostly ripped from+-- https://github.com/ekmett/lens/blob/697582fb9a980f273dbf8496253c5bbefedd0a8b/Setup.lhs+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ , postHaddock = \args flags pkg lbi -> do+ copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]+ postHaddock simpleUserHooks args flags pkg lbi+ }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+ baseDir = case haddockDistPref flags of+ NoFlag -> "."+ Flag x -> x+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ withLibLBI pkg lbi $ \_ libcfg -> do+ withTestLBI pkg lbi $ \suite suitecfg -> do+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+ [ "module Build_" ++ testName suite ++ " where"+ , "import Prelude"+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+
+ doctest/Main.hs view
@@ -0,0 +1,66 @@+-- The code is mostly ripped from+-- https://github.com/ekmett/lens/blob/d1d97469f0e93c1d3535308954a060e8a04e37aa/tests/doctests.hsc+import BasePrelude+import System.Directory+import System.FilePath+import Test.DocTest+import Build_doctest (deps)++main :: IO ()+main = do+ sources <- getSources+ doctest $ dfltParams ++ map ("-package="++) deps ++ sources+ where+ dfltParams = + [+ "-isrc",+ "-idist/build/autogen",+ "-optP-include",+ "-optPdist/build/autogen/cabal_macros.h",+ "-XArrows",+ "-XBangPatterns",+ "-XConstraintKinds",+ "-XDataKinds",+ "-XDefaultSignatures",+ "-XDeriveDataTypeable",+ "-XDeriveFunctor",+ "-XDeriveGeneric",+ "-XEmptyDataDecls",+ "-XFlexibleContexts",+ "-XFlexibleInstances",+ "-XFunctionalDependencies",+ "-XGADTs",+ "-XGeneralizedNewtypeDeriving",+ "-XImpredicativeTypes",+ "-XLambdaCase",+ "-XLiberalTypeSynonyms",+ "-XMultiParamTypeClasses",+ "-XMultiWayIf",+ "-XNoImplicitPrelude",+ "-XNoMonomorphismRestriction",+ "-XOverloadedStrings",+ "-XPatternGuards",+ "-XParallelListComp",+ "-XQuasiQuotes",+ "-XRankNTypes",+ "-XRecordWildCards",+ "-XScopedTypeVariables",+ "-XStandaloneDeriving",+ "-XTemplateHaskell",+ "-XTupleSections",+ "-XTypeFamilies",+ "-XTypeOperators",+ "-hide-all-packages"+ ]++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "library"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
hasql-postgres.cabal view
@@ -1,7 +1,7 @@ name: hasql-postgres version:- 0.8.0+ 0.9.0 synopsis: A "PostgreSQL" backend for the "hasql" library description:@@ -34,9 +34,11 @@ license-file: LICENSE build-type:- Simple+ Custom cabal-version: >=1.10+extra-source-files:+ CHANGELOG.md source-repository head@@ -88,8 +90,8 @@ bytestring >= 0.10 && < 0.11, hashable >= 1.1 && < 1.3, -- control:- either == 4.*,- list-t < 0.4,+ either >= 4.3 && < 4.4,+ list-t < 0.5, mmorph == 1.0.*, transformers >= 0.3 && < 0.5, -- errors:@@ -100,65 +102,33 @@ base >= 4.5 && < 4.8 -test-suite library-tests- type: +test-suite doctest+ type: exitcode-stdio-1.0- hs-source-dirs: - library-tests- library- main-is: + hs-source-dirs:+ doctest+ main-is: Main.hs- other-modules:- Hasql.Postgres.TemplateConverterTests ghc-options: -threaded- "-with-rtsopts=-N"- -funbox-strict-fields+ build-depends:+ doctest == 0.9.*,+ directory == 1.2.*,+ filepath == 1.3.*,+ base-prelude == 0.1.*,+ base >= 4.5 && < 5 default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators default-language: Haskell2010- build-depends:- -- testing:- HTF == 0.12.*,- quickcheck-instances == 0.3.*,- QuickCheck == 2.7.*,- -- template haskell:- template-haskell == 2.*,- -- parsers:- attoparsec >= 0.10 && < 0.13,- -- database:- hasql == 0.4.*,- postgresql-binary == 0.5.*,- postgresql-libpq == 0.9.*,- -- data:- uuid == 1.3.*,- vector == 0.10.*,- time >= 1.4 && < 1.6,- hashtables >= 1.1 && < 1.3,- scientific >= 0.2 && < 0.4,- text >= 1 && < 1.3,- bytestring >= 0.10 && < 0.11,- hashable >= 1.1 && < 1.3,- -- control:- either == 4.*,- list-t < 0.4,- mmorph == 1.0.*,- transformers >= 0.3 && < 0.5,- -- errors:- loch-th == 0.2.*,- placeholders == 0.1.*,- -- general:- base-prelude >= 0.1.3 && < 0.2,- base >= 4.5 && < 4.8 -test-suite tests- type: +test-suite hspec+ type: exitcode-stdio-1.0- hs-source-dirs: - tests- main-is: + hs-source-dirs:+ hspec+ main-is: Main.hs ghc-options: -threaded@@ -171,9 +141,9 @@ build-depends: hasql-postgres, hasql-backend,- hasql == 0.4.*,+ hasql >= 0.4 && < 0.6, -- testing:- HTF == 0.12.*,+ hspec == 2.1.*, quickcheck-instances == 0.3.*, QuickCheck == 2.7.*, -- concurrency:@@ -188,7 +158,7 @@ bytestring >= 0.10 && < 0.11, hashable >= 1.1 && < 1.3, -- general:- list-t < 0.4,+ list-t < 0.5, mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8@@ -216,7 +186,7 @@ postgresql-simple == 0.4.*, hasql-postgres, hasql-backend,- hasql == 0.4.*,+ hasql >= 0.4 && < 0.6, -- random: QuickCheck == 2.7.*, quickcheck-instances == 0.3.*,@@ -228,9 +198,9 @@ text >= 1 && < 1.3, scientific >= 0.2 && < 0.4, -- general:- monad-control == 0.3.*,+ monad-control >= 0.3 && < 1.1, deepseq == 1.3.*,- list-t < 0.4,+ list-t < 0.5, mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8
+ hspec/Main.hs view
@@ -0,0 +1,238 @@+module Main where++import BasePrelude hiding (assert)+import MTLPrelude+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances+import Hasql+import Hasql.Postgres (Postgres(..))+import Data.Time+import qualified Data.Text+import qualified Data.Text.Lazy+import qualified Data.ByteString+import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Lazy.Char8+import qualified ListT+import qualified SlaveThread+import qualified Control.Concurrent.SSem as SSem+import qualified Hasql.Backend as Backend+import qualified Hasql as H+import qualified Hasql.Postgres as HP+import qualified Data.Scientific as Scientific+import qualified Data.Vector as Vector+++type Text = Data.Text.Text+type LazyText = Data.Text.Lazy.Text+type ByteString = Data.ByteString.ByteString+type LazyByteString = Data.ByteString.Lazy.ByteString+type Scientific = Scientific.Scientific+++main = + hspec $ do++ describe "Feature" $ do+ + it "wrongPort" $ do+ let + backendSettings = HP.ParamSettings "localhost" 1 "postgres" "" "postgres"+ poolSettings = fromJust $ sessionSettings 6 30+ io =+ H.session backendSettings poolSettings $ do+ H.tx Nothing $ H.unit [H.q|DROP TABLE IF EXISTS a|]+ in+ shouldThrow io $ \case+ H.CantConnect _ -> True+ _ -> False++ it "sameStatementUsedOnDifferentTypes" $ do+ session1 $ do+ liftIO . (flip shouldBe) (Just (Identity ("abc" :: Text))) =<< do + H.tx Nothing $ H.single $ [H.q|SELECT ?|] ("abc" :: Text)+ liftIO . (flip shouldBe) (Just (Identity True)) =<< do + H.tx Nothing $ H.single $ [H.q|SELECT ?|] True++ it "rendering" $ do+ let rows = [("A", 34525), ("B", 324987)] :: [(Text, Int)]+ (flip shouldBe) (Just $ head rows) =<< do + session1 $ do+ H.tx Nothing $ do+ H.unit [H.q|DROP TABLE IF EXISTS a|]+ H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday INT8,+ PRIMARY KEY (id))|]+ forM_ rows $ \(name, birthday) -> do+ H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday+ H.tx Nothing $ do+ H.single $ [H.q|SELECT name, birthday FROM a WHERE id = ? |] (1 :: Int)++ it "countEffects" $ do+ (flip shouldBe) 100 =<< do + session1 $ do+ tx Nothing $ do+ unit [q|DROP TABLE IF EXISTS a|]+ unit [q|CREATE TABLE a (id SERIAL NOT NULL, name VARCHAR NOT NULL)|]+ replicateM_ 100 $ do+ unit [q|INSERT INTO a (name) VALUES ('a')|]+ count [q|DELETE FROM a|]++ it "autoIncrement" $ do+ (flip shouldBe) (Just (1 :: Word64), Just (2 :: Word64)) =<< do+ session1 $ tx Nothing $ do+ unit [q|DROP TABLE IF EXISTS a|]+ unit [q|CREATE TABLE a (id SERIAL NOT NULL, v INT8, PRIMARY KEY (id))|]+ id1 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (1) RETURNING id|]+ id2 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (2) RETURNING id|]+ return (id1, id2)++ it "cursorResultsOrder" $ do+ session1 $ do+ r :: [Word] <-+ tx (Just (ReadCommitted, False)) $ do+ ListT.toList $ fmap runIdentity $ stream $ + [q|select oid from pg_type ORDER BY oid|]+ liftIO $ (flip shouldBe) (sort r) r++ it "cursor" $ do+ session1 $ do+ r :: [(Word, Text)] <-+ tx (Just (ReadCommitted, False)) $ do+ ListT.toList $ stream $+ [q|select oid, typname from pg_type|]+ r' :: [(Word, Text)] <-+ tx (Just (ReadCommitted, False)) $ do+ list $ [q|select oid, typname from pg_type|]+ liftIO $ (flip shouldBe) r' r++ it "select" $ do+ session1 $ do+ r :: [(Word, Text)] <-+ tx Nothing $ do+ list $ [q|select oid, typname from pg_type|]+ liftIO $ (flip shouldBe) True $ not $ null r++ describe "Mapping of" $ do++ describe "Maybe" $ do+ it "" $ do+ session1 $ do+ validMappingSession (Just '!')+ validMappingSession (Nothing :: Maybe Bool)+ + describe "List" $ do++ it "1" $ do+ let+ v1 = [v2, v2]+ v2 = [Just 'a', Nothing, Just 'b']+ session1 $ do+ validMappingSession v1+ validMappingSession v2++ it "2" $ do+ let+ v1 = [v2, v2]+ v2 = [Just (1 :: Int), Just 2, Nothing]+ session1 $ do+ validMappingSession v1+ validMappingSession v2++ it "3" $ do+ session1 $ do+ validMappingSession [" 'a' \"b\" \\c\\ " :: Text]++ it "4" $ do+ let+ v1 =+ [+ [Just 'a', Just 'b'],+ [Nothing, Just 'c']+ ]+ (flip shouldBe) (Just (Identity v1)) =<< do+ session1 $ tx Nothing $ do+ unit $ [q|DROP TABLE IF EXISTS a|]+ unit $ [q|CREATE TABLE a ("v" char[][])|]+ unit $ [q|INSERT INTO a (v) VALUES (?)|] v1+ single $ [q|SELECT v FROM a|]++ it "5" $ do+ session1 $ do+ validMappingSession [" 'a' \"b\" \\c\\ ф" :: ByteString]++ it "ByteString" $ property $ \(x :: [ByteString]) ->+ mappingProp x++ it "LazyByteString" $ property $ \(x :: [LazyByteString]) ->+ mappingProp x++ it "LazyText" $ property $ \(v :: LazyText) ->+ (isNothing $ Data.Text.Lazy.find (== '\NUL') v) ==>+ mappingProp v++ it "LazyByteString" $ property $ \(v :: LazyByteString) ->+ mappingProp v+++-- * Helpers+-------------------------++-- ** Generators+-------------------------++scientificGen :: Gen Scientific+scientificGen =+ Scientific.scientific <$> arbitrary <*> arbitrary++microsTimeOfDayGen :: Gen TimeOfDay+microsTimeOfDayGen =+ timeToTimeOfDay <$> microsDiffTimeGen++microsLocalTimeGen :: Gen LocalTime+microsLocalTimeGen = + LocalTime <$> arbitrary <*> microsTimeOfDayGen++microsDiffTimeGen :: Gen DiffTime+microsDiffTimeGen = do+ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ choose (0, (10^6)*24*60*60)++-- ** Session+-------------------------++selectSelf :: + Backend.Mapping Postgres a => + a -> Session Postgres s IO (Maybe a)+selectSelf v =+ tx Nothing $ (fmap . fmap) runIdentity $ single $ [q| SELECT ? |] v++session1 :: (forall s. Session Postgres s IO r) -> IO r+session1 =+ session backendSettings poolSettings+ where+ backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"+ poolSettings = fromJust $ sessionSettings 6 30++validMappingSession :: + Backend.Mapping Postgres a => Typeable a => Show a => Eq a => + a -> Session Postgres s IO ()+validMappingSession v =+ selectSelf v >>= liftIO . (flip shouldBe) (Just v)++-- ** Property+-------------------------++floatEqProp :: RealFrac a => Show a => a -> a -> Property+floatEqProp a b =+ counterexample (show a ++ " /~ " ++ show b) $+ a + error >= b && a - error <= b+ where+ error = max (abs a) 1 / 100++mappingProp :: (Show a, Eq a, Backend.Mapping Postgres a) => a -> Property+mappingProp v =+ Right v === do + unsafePerformIO $ (try :: IO a -> IO (Either H.Error a)) $ fmap fromJust $ + session1 $ selectSelf v
− library-tests/Hasql/Postgres/TemplateConverterTests.hs
@@ -1,15 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Hasql.Postgres.TemplateConverterTests where--import Test.Framework-import Hasql.Postgres.Prelude-import qualified Data.Text.Encoding-import qualified Hasql.Postgres.TemplateConverter---test_convert =- assertEqual- (Right "asdf $1 \"'\\\"?'\" d 2$2$3")- (Hasql.Postgres.TemplateConverter.convert "asdf ? \"'\\\"?'\" d 2??")- -
− library-tests/Main.hs
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import Test.Framework-import Hasql.Postgres.Prelude--import {-@ HTF_TESTS @-} Hasql.Postgres.TemplateConverterTests--main = - htfMain $ htf_thisModulesTests : htf_importedTests
library/Hasql/Postgres/Session/ResultProcessing.hs view
@@ -88,7 +88,7 @@ unit :: PQ.Result -> M () unit r =- checkStatus (\case PQ.CommandOk -> True; _ -> False) r+ checkStatus (\case PQ.CommandOk -> True; PQ.TuplesOk -> True; _ -> False) r count :: PQ.Result -> M Word64 count r =
library/Hasql/Postgres/TemplateConverter.hs view
@@ -7,6 +7,10 @@ import qualified Hasql.Postgres.TemplateConverter.Parser as Parser +-- |+-- +-- >>> convert "asdf ? \"'\\\"?'\" d 2??"+-- Right "asdf $1 \"'\\\"?'\" d 2$2$3" convert :: ByteString -> Either Text ByteString convert t = do
− tests/Main.hs
@@ -1,237 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import BasePrelude hiding (assert)-import MTLPrelude-import Test.Framework-import Test.QuickCheck-import Test.QuickCheck.Instances-import Hasql-import Hasql.Postgres (Postgres(..))-import Data.Time-import qualified Data.Text-import qualified Data.Text.Lazy-import qualified Data.ByteString-import qualified Data.ByteString.Char8-import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Lazy.Char8-import qualified ListT-import qualified SlaveThread-import qualified Control.Concurrent.SSem as SSem-import qualified Hasql.Backend as Backend-import qualified Hasql as H-import qualified Hasql.Postgres as HP-import qualified Data.Scientific as Scientific-import qualified Data.Vector as Vector---type Text = Data.Text.Text-type LazyText = Data.Text.Lazy.Text-type ByteString = Data.ByteString.ByteString-type LazyByteString = Data.ByteString.Lazy.ByteString-type Scientific = Scientific.Scientific--main = - htfMain $ htf_thisModulesTests---test_wrongPort =- let - backendSettings = HP.ParamSettings "localhost" 1 "postgres" "" "postgres"- poolSettings = fromJust $ sessionSettings 6 30- io =- H.session backendSettings poolSettings $ do- H.tx Nothing $ H.unit [H.q|DROP TABLE IF EXISTS a|]- in - assertThrowsIO io $ \case- H.CantConnect _ -> True- _ -> False--test_sameStatementUsedOnDifferentTypes =- session1 $ do- liftIO . assertEqual (Just (Identity ("abc" :: Text))) =<< do - H.tx Nothing $ H.single $ [H.q|SELECT ?|] ("abc" :: Text)- liftIO . assertEqual (Just (Identity True)) =<< do - H.tx Nothing $ H.single $ [H.q|SELECT ?|] True--test_rendering =- assertEqual (Just $ head rows) =<< do - session1 $ do- H.tx Nothing $ do- H.unit [H.q|DROP TABLE IF EXISTS a|]- H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, - name VARCHAR NOT NULL, - birthday INT8,- PRIMARY KEY (id))|]- forM_ rows $ \(name, birthday) -> do- H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday- H.tx Nothing $ do- H.single $ [H.q|SELECT name, birthday FROM a WHERE id = ? |] (1 :: Int)- where- rows = [("A", 34525), ("B", 324987)] :: [(Text, Int)]--test_countEffects =- assertEqual 100 =<< do - session1 $ do- tx Nothing $ do- unit [q|DROP TABLE IF EXISTS a|]- unit [q|CREATE TABLE a (id SERIAL NOT NULL, name VARCHAR NOT NULL)|]- replicateM_ 100 $ do- unit [q|INSERT INTO a (name) VALUES ('a')|]- count [q|DELETE FROM a|]--test_autoIncrement =- assertEqual (Just (1 :: Word64), Just (2 :: Word64)) =<< do- session1 $ tx Nothing $ do- unit [q|DROP TABLE IF EXISTS a|]- unit [q|CREATE TABLE a (id SERIAL NOT NULL, v INT8, PRIMARY KEY (id))|]- id1 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (1) RETURNING id|]- id2 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (2) RETURNING id|]- return (id1, id2)--test_cursorResultsOrder =- session1 $ do- r :: [Word] <-- tx (Just (ReadCommitted, False)) $ do- ListT.toList $ fmap runIdentity $ stream $ - [q|select oid from pg_type ORDER BY oid|]- liftIO $ assertEqual (sort r) r--test_cursor =- session1 $ do- r :: [(Word, Text)] <-- tx (Just (ReadCommitted, False)) $ do- ListT.toList $ stream $- [q|select oid, typname from pg_type|]- r' :: [(Word, Text)] <-- tx (Just (ReadCommitted, False)) $ do- list $ [q|select oid, typname from pg_type|]- liftIO $ assertEqual r' r--test_select =- session1 $ do- r :: [(Word, Text)] <-- tx Nothing $ do- list $ [q|select oid, typname from pg_type|]- liftIO $ assertNotEqual [] r----- * Mappings----------------------------test_mappingOfMaybe =- session1 $ do- validMappingSession (Just '!')- validMappingSession (Nothing :: Maybe Bool)--test_mappingOfVector1 =- session1 $ do- validMappingSession v1- validMappingSession v2- where- v1 = [v2, v2]- v2 = [Just 'a', Nothing, Just 'b']--test_mappingOfList2 =- session1 $ do- validMappingSession v1- validMappingSession v2- where- v1 = [v2, v2]- v2 = [Just (1 :: Int), Just 2, Nothing]--test_mappingOfList3 =- session1 $ do- validMappingSession [" 'a' \"b\" \\c\\ " :: Text]--test_mappingOfList4 =- assertEqual (Just (Identity v1)) =<< do- session1 $ tx Nothing $ do- unit $ [q|DROP TABLE IF EXISTS a|]- unit $ [q|CREATE TABLE a ("v" char[][])|]- unit $ [q|INSERT INTO a (v) VALUES (?)|] v1- single $ [q|SELECT v FROM a|]- where- v1 =- [- [Just 'a', Just 'b'],- [Nothing, Just 'c']- ]--test_mappingOfList5 =- session1 $ do- validMappingSession [" 'a' \"b\" \\c\\ ф" :: ByteString]--prop_mappingOfListOverByteString (x :: [ByteString]) =- mappingProp x--prop_mappingOfListOverLazyByteString (x :: [LazyByteString]) =- mappingProp x--prop_mappingOfLazyText (v :: LazyText) =- (isNothing $ Data.Text.Lazy.find (== '\NUL') v) ==>- mappingProp v--prop_mappingOfLazyByteString (v :: LazyByteString) =- mappingProp v----- * Helpers------------------------------ ** Generators----------------------------scientificGen :: Gen Scientific-scientificGen =- Scientific.scientific <$> arbitrary <*> arbitrary--microsTimeOfDayGen :: Gen TimeOfDay-microsTimeOfDayGen =- timeToTimeOfDay <$> microsDiffTimeGen--microsLocalTimeGen :: Gen LocalTime-microsLocalTimeGen = - LocalTime <$> arbitrary <*> microsTimeOfDayGen--microsDiffTimeGen :: Gen DiffTime-microsDiffTimeGen = do- fmap picosecondsToDiffTime $ fmap (* (10^6)) $ choose (0, (10^6)*24*60*60)---- ** Session----------------------------selectSelf :: - Backend.Mapping Postgres a => - a -> Session Postgres s IO (Maybe a)-selectSelf v =- tx Nothing $ (fmap . fmap) runIdentity $ single $ [q| SELECT ? |] v--validMappingSession :: - Backend.Mapping Postgres a => Typeable a => Show a => Eq a => - a -> Session Postgres s IO ()-validMappingSession v =- selectSelf v >>= liftIO . assertEqual (Just v)--session1 :: (forall s. Session Postgres s IO r) -> IO r-session1 =- session backendSettings poolSettings- where- backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"- poolSettings = fromJust $ sessionSettings 6 30---- ** Property----------------------------floatEqProp :: RealFrac a => Show a => a -> a -> Property-floatEqProp a b =- counterexample (show a ++ " /~ " ++ show b) $- a + error >= b && a - error <= b- where- error = max (abs a) 1 / 100--mappingProp :: (Show a, Eq a, Backend.Mapping Postgres a) => a -> Property-mappingProp v =- Right v === do - unsafePerformIO $ (try :: IO a -> IO (Either H.Error a)) $ fmap fromJust $ - session1 $ selectSelf v