postgresql-simple 0.3.0.1 → 0.3.1.0
raw patch · 12 files changed
+455/−23 lines, 12 files
Files
- postgresql-simple.cabal +6/−2
- src/Database/PostgreSQL/Simple.hs +2/−2
- src/Database/PostgreSQL/Simple/FromField.hs +57/−5
- src/Database/PostgreSQL/Simple/FromField.hs-boot +1/−0
- src/Database/PostgreSQL/Simple/FromRow.hs +1/−1
- src/Database/PostgreSQL/Simple/FromRow.hs-boot +12/−2
- src/Database/PostgreSQL/Simple/HStore.hs +36/−0
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +210/−0
- src/Database/PostgreSQL/Simple/HStore/Internal.hs +22/−0
- src/Database/PostgreSQL/Simple/TypeInfo.hs +68/−10
- src/Database/PostgreSQL/Simple/TypeInfo/Types.hs +26/−0
- test/Main.hs +14/−1
postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name: postgresql-simple-Version: 0.3.0.1+Version: 0.3.1.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -26,6 +26,8 @@ Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow Database.PostgreSQL.Simple.LargeObjects+ Database.PostgreSQL.Simple.HStore+ Database.PostgreSQL.Simple.HStore.Internal Database.PostgreSQL.Simple.Notification Database.PostgreSQL.Simple.Ok Database.PostgreSQL.Simple.SqlQQ@@ -43,6 +45,7 @@ Other-modules: Database.PostgreSQL.Simple.Compat+ Database.PostgreSQL.Simple.HStore.Implementation Database.PostgreSQL.Simple.Time.Implementation Database.PostgreSQL.Simple.TypeInfo.Types @@ -72,7 +75,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple- tag: v0.3.0.1+ tag: v0.3.1.0 test-suite test type: exitcode-stdio-1.0@@ -100,6 +103,7 @@ build-depends: base , base16-bytestring , bytestring+ , containers , cryptohash , HUnit , postgresql-simple
src/Database/PostgreSQL/Simple.hs view
@@ -736,7 +736,7 @@ -- * There must be no other \"@?@\" characters anywhere in your -- template. ----- * There must one or more \"@?@\" in the parentheses.+-- * There must be one or more \"@?@\" in the parentheses. -- -- * Extra white space is fine. --@@ -805,7 +805,7 @@ -- -- Although SQL can accommodate @NULL@ as a value for any of these -- types, Haskell cannot. If your result contains columns that may be--- @NULL@, be sure that you use 'Maybe' in those positions of of your+-- @NULL@, be sure that you use 'Maybe' in those positions of your -- tuple. -- -- > (Text, Maybe Int, Int)
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -14,6 +14,8 @@ The 'FromField' typeclass, for converting a single value in a row returned by a SQL query into a more useful Haskell representation.+Note that each instance of 'FromField' is documented by a list of+compatible postgresql types. A Haskell numeric type is considered to be compatible with all PostgreSQL numeric types that are less accurate than it. For instance,@@ -39,11 +41,11 @@ if typeOid f /= builtin2oid UUID then returnError Incompatible f \"\" else case B.unpack \`fmap\` mdata of- Nothing -> returnError UnexpectedNull f \"\"- Just data ->- case [ x | (x,t) <- reads data, (\"\",\"\") <- lex t ] of- [x] -> Ok x- _ -> returnError ConversionError f data+ Nothing -> returnError UnexpectedNull f \"\"+ Just dat ->+ case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of+ [x] -> return x+ _ -> returnError ConversionError f dat @ Note that because PostgreSQL's @uuid@ type is built into postgres and is@@ -74,6 +76,7 @@ , Field , typename , TypeInfo(..)+ , Attribute(..) , typeInfo , typeInfoByOid , name@@ -225,14 +228,20 @@ format :: Field -> PQ.Format format Field{..} = unsafeDupablePerformIO (PQ.fformat result column) +-- | For dealing with null values. Compatible with any postgresql type+-- compatible with type @a@. Note that the type is not checked if+-- the value is null, although it is inadvisable to rely on this+-- behavior. instance (FromField a) => FromField (Maybe a) where fromField _ Nothing = pure Nothing fromField f bs = Just <$> fromField f bs +-- | compatible with any data type, but the value must be null instance FromField Null where fromField _ Nothing = pure Null fromField f (Just _) = returnError ConversionFailed f "data is not null" +-- | bool instance FromField Bool where fromField f bs | typeOid f /= typoid (TypeInfo.bool) = returnError Incompatible f ""@@ -241,29 +250,54 @@ | bs == Just "f" = pure False | otherwise = returnError ConversionFailed f "" +-- | \"char\"+instance FromField Char where+ fromField f bs =+ if typeOid f /= typoid (TypeInfo.char)+ then returnError Incompatible f ""+ else case bs of+ Nothing -> returnError UnexpectedNull f ""+ Just bs -> if B.length bs /= 1+ then returnError ConversionFailed f "length not 1"+ else return $! (B.head bs)++-- | int2 instance FromField Int16 where fromField = atto ok16 $ signed decimal +-- | int2, int4 instance FromField Int32 where fromField = atto ok32 $ signed decimal +#if WORD_SIZE_IN_BITS < 64+-- | int2, int4, and if compiled as 64-bit code, int8 as well.+-- This library was compiled as 32-bit code.+#else+-- | int2, int4, and if compiled as 64-bit code, int8 as well.+-- This library was compiled as 64-bit code.+#endif instance FromField Int where fromField = atto okInt $ signed decimal +-- | int2, int4, int8 instance FromField Int64 where fromField = atto ok64 $ signed decimal +-- | int2, int4, int8 instance FromField Integer where fromField = atto ok64 $ signed decimal +-- | int2, float4 instance FromField Float where fromField = atto ok (realToFrac <$> double) where ok = mkCompats [Float4,Int2] +-- | int2, int4, float4, float8 instance FromField Double where fromField = atto ok double where ok = mkCompats [Float4,Float8,Int2,Int4] +-- | int2, int4, float4, float8, numeric instance FromField (Ratio Integer) where fromField = atto ok rational where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]@@ -271,14 +305,17 @@ unBinary :: Binary t -> t unBinary (Binary x) = x +-- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField SB.ByteString where fromField f dat = if typeOid f == typoid TypeInfo.bytea then unBinary <$> fromField f dat else doFromField f okText' (pure . B.copy) dat +-- | oid instance FromField PQ.Oid where fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat +-- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat @@ -288,48 +325,62 @@ Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) +-- | bytea instance FromField (Binary SB.ByteString) where fromField f dat = case format f of PQ.Text -> doFromField f okBinary (unescapeBytea f) dat PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat +-- | bytea instance FromField (Binary LB.ByteString) where fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat +-- | name, text, \"char\", bpchar, varchar instance FromField ST.Text where fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8') -- FIXME: check character encoding +-- | name, text, \"char\", bpchar, varchar instance FromField LT.Text where fromField f dat = LT.fromStrict <$> fromField f dat +-- | name, text, \"char\", bpchar, varchar instance FromField [Char] where fromField f dat = ST.unpack <$> fromField f dat +-- | timestamptz instance FromField UTCTime where fromField = ff TypeInfo.timestamptz "UTCTime" parseUTCTime +-- | timestamptz instance FromField ZonedTime where fromField = ff TypeInfo.timestamptz "ZonedTime" parseZonedTime +-- | timestamp instance FromField LocalTime where fromField = ff TypeInfo.timestamp "LocalTime" parseLocalTime +-- | date instance FromField Day where fromField = ff TypeInfo.date "Day" parseDay +-- | time instance FromField TimeOfDay where fromField = ff TypeInfo.time "TimeOfDay" parseTimeOfDay +-- | timestamptz instance FromField UTCTimestamp where fromField = ff TypeInfo.timestamptz "UTCTimestamp" parseUTCTimestamp +-- | timestamptz instance FromField ZonedTimestamp where fromField = ff TypeInfo.timestamptz "ZonedTimestamp" parseZonedTimestamp +-- | timestamp instance FromField LocalTimestamp where fromField = ff TypeInfo.timestamp "LocalTimestamp" parseLocalTimestamp +-- | date instance FromField Date where fromField = ff TypeInfo.date "Date" parseDate @@ -357,6 +408,7 @@ fromField f dat = (Right <$> fromField f dat) <|> (Left <$> fromField f dat) +-- | any postgresql array whose elements are compatible with type @a@ instance (FromField a, Typeable a) => FromField (Vector a) where fromField f mdat = do info <- typeInfo f
src/Database/PostgreSQL/Simple/FromField.hs-boot view
@@ -6,5 +6,6 @@ class FromField a instance FromField Oid+instance FromField Char instance FromField ByteString instance FromField a => FromField (Maybe a)
src/Database/PostgreSQL/Simple/FromRow.hs view
@@ -44,7 +44,7 @@ -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. ----- Note that instances can defined outside of postgresql-simple, which is+-- Note that instances can be defined outside of postgresql-simple, which is -- often useful. For example, here's an instance for a user-defined pair: -- -- @data User = User { name :: String, fileQuota :: Int }
src/Database/PostgreSQL/Simple/FromRow.hs-boot view
@@ -1,8 +1,18 @@ module Database.PostgreSQL.Simple.FromRow where import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.Types class FromRow a -instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d)-instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e)+instance (FromField a) => FromRow (Only a)+instance (FromField a, FromField b)+ => FromRow (a,b)+instance (FromField a, FromField b, FromField c, FromField d) + => FromRow (a,b,c,d)+instance (FromField a, FromField b, FromField c, FromField d, FromField e) + => FromRow (a,b,c,d,e)+instance (FromField a, FromField b, FromField c, FromField d, FromField e+ ,FromField f) + => FromRow (a,b,c,d,e,f)+
+ src/Database/PostgreSQL/Simple/HStore.hs view
@@ -0,0 +1,36 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.HStore+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- Parsers and printers for hstore, a extended type bundled with+-- PostgreSQL providing finite maps from text strings to text strings.+-- See <http://www.postgresql.org/docs/9.2/static/hstore.html> for more+-- information.+--+-- Note that in order to use this type, a database superuser must+-- install it by running a sql script in the share directory. This+-- can be done on PostgreSQL 9.1 and later with the command+-- @CREATE EXTENSION hstore@. See+-- <http://www.postgresql.org/docs/9.2/static/contrib.html> for more+-- information.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.HStore+ ( HStoreList(..)+ , HStoreMap(..)+ , ToHStore(..)+ , HStoreBuilder+ , toBuilder+ , toLazyByteString+ , hstore+ , ToHStoreText(..)+ , HStoreText+ ) where++import Database.PostgreSQL.Simple.HStore.Implementation
+ src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.HStore.Implementation+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- This code has yet to be profiled and optimized.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.HStore.Implementation where++import Control.Applicative+import Blaze.ByteString.Builder as Blaze+ ( Builder, toLazyByteString, copyByteString )+import Blaze.ByteString.Builder.Char8 (fromChar)+import qualified Data.Attoparsec.ByteString as P+import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)+import qualified Data.ByteString as BS+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Internal as BL+import Data.Map(Map)+import qualified Data.Map as Map+import Data.Text(Text)+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TS+import Data.Text.Encoding.Error(UnicodeException)+import qualified Data.Text.Lazy as TL+import Data.Typeable+import Data.Monoid(Monoid(..))+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField++class ToHStore a where+ toHStore :: a -> HStoreBuilder++-- | Represents valid hstore syntax.+data HStoreBuilder+ = Empty+ | Comma !Builder+ deriving (Typeable)++instance ToHStore HStoreBuilder where+ toHStore = id++toBuilder :: HStoreBuilder -> Builder+toBuilder x = case x of+ Empty -> mempty+ Comma x -> x++toLazyByteString :: HStoreBuilder -> BL.ByteString+toLazyByteString x = case x of+ Empty -> BL.empty+ Comma x -> Blaze.toLazyByteString x++instance Monoid HStoreBuilder where+ mempty = Empty+ mappend Empty x = x+ mappend (Comma a) x+ = Comma (a `mappend` case x of+ Empty -> mempty+ Comma b -> fromChar ',' `mappend` b)++class ToHStoreText a where+ toHStoreText :: a -> HStoreText++-- | Represents escape text, ready to be the key or value to a hstore value+newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)++instance ToHStoreText HStoreText where+ toHStoreText = id++-- | Assumed to be UTF-8 encoded+instance ToHStoreText BS.ByteString where+ toHStoreText str = HStoreText (escapeAppend str mempty)++-- | Assumed to be UTF-8 encoded+instance ToHStoreText BL.ByteString where+ toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty++instance ToHStoreText TS.Text where+ toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty)++instance ToHStoreText TL.Text where+ toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty++escapeAppend :: BS.ByteString -> Builder -> Builder+escapeAppend = loop+ where+ loop (BS.break quoteNeeded -> (a,b)) rest+ = copyByteString a `mappend`+ case BS.uncons b of+ Nothing -> rest+ Just (c,d) -> quoteChar c `mappend` loop d rest++ quoteNeeded c = c == c2w '\"' || c == c2w '\\'+ quoteChar c+ | c == c2w '\"' = copyByteString "\\\""+ | otherwise = copyByteString "\\\\"++hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder+hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =+ Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""+ `mappend` val `mappend` fromChar '"')++instance ToField HStoreBuilder where+ toField Empty = toField (BS.empty)+ toField (Comma x) = toField (Blaze.toLazyByteString x)++newtype HStoreList = HStoreList [(Text,Text)] deriving (Typeable, Show)++instance ToHStore HStoreList where+ toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs)++instance ToField HStoreList where+ toField xs = toField (toHStore xs)++instance FromField HStoreList where+ fromField f mdat = do+ typ <- typename f+ if typ /= "hstore"+ then returnError Incompatible f ""+ else case mdat of+ Nothing -> returnError UnexpectedNull f ""+ Just dat ->+ case P.parseOnly parseHStore dat of+ Left err ->+ returnError ConversionFailed f err+ Right (Left err) ->+ returnError ConversionFailed f "unicode exception" <|>+ conversionError err+ Right (Right val) ->+ return val++newtype HStoreMap = HStoreMap (Map Text Text) deriving (Eq, Ord, Typeable, Show)++instance ToHStore HStoreMap where+ toHStore (HStoreMap xs) = Map.foldWithKey f mempty xs+ where f k v xs = hstore k v `mappend` xs++instance ToField HStoreMap where+ toField xs = toField (toHStore xs)++instance FromField HStoreMap where+ fromField f mdat = convert <$> fromField f mdat+ where convert (HStoreList xs) = HStoreMap (Map.fromList xs)++parseHStore :: P.Parser (Either UnicodeException HStoreList)+parseHStore = skipWhiteSpace >> loop id+ where+ loop acc = do+ mkv <- parseHStoreKeyVal+ case mkv of+ Left err -> return (Left err)+ Right kv -> do+ skipWhiteSpace+ (do+ _ <- P.word8 (c2w ',')+ skipWhiteSpace+ loop (acc . (kv:))+ ) <|> return (Right (HStoreList (acc [kv])))++parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text))+parseHStoreKeyVal = do+ mkey <- parseHStoreText+ case mkey of+ Left err -> return (Left err)+ Right key -> do+ skipWhiteSpace+ _ <- P.string "=>"+ skipWhiteSpace+ mval <- parseHStoreText+ case mval of+ Left err -> return (Left err)+ Right val -> return (Right (key,val))+++skipWhiteSpace :: P.Parser ()+skipWhiteSpace = P.skipWhile P.isSpace_w8++parseHStoreText :: P.Parser (Either UnicodeException Text)+parseHStoreText = do+ _ <- P.word8 (c2w '"')+ mtexts <- parseHStoreTexts id+ case mtexts of+ Left err -> return (Left err)+ Right texts -> do+ _ <- P.word8 (c2w '"')+ return (Right (TS.concat texts))++parseHStoreTexts :: ([Text] -> [Text])+ -> P.Parser (Either UnicodeException [Text])+parseHStoreTexts acc = do+ mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar)+ case mchunk of+ Left err -> return (Left err)+ Right chunk ->+ (do+ _ <- P.word8 (c2w '\\')+ c <- TS.singleton . w2c <$> P.satisfy isSpecialChar+ parseHStoreTexts (acc . (chunk:) . (c:))+ ) <|> return (Right (acc [chunk]))+ where+ isSpecialChar c = c == c2w '\\' || c == c2w '"'
+ src/Database/PostgreSQL/Simple/HStore/Internal.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_HADDOCK hide #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.HStore.Internal+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.HStore.Internal+ ( HStoreBuilder(..)+ , HStoreText(..)+ , parseHStore+ , parseHStoreKeyVal+ , parseHStoreText+ ) where++import Database.PostgreSQL.Simple.HStore.Implementation
src/Database/PostgreSQL/Simple/TypeInfo.hs view
@@ -8,15 +8,30 @@ -- Maintainer: Leon P Smith <leon@melding-monads.com> -- Stability: experimental --+-- This module provides convenient and efficient access to parts of the+-- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if+-- you need to work with types that do not appear in+-- 'Database.PostgreSQL.Simple.TypeInfo.Static'.+--+-- The current scheme could be more efficient, especially for some use+-- cases. In particular, connection pools that use many user-added+-- types and connect to a set of servers with identical (or at least+-- compatible) @pg_type@ and associated tables could share a common+-- typeinfo cache, thus saving memory and communication between the+-- client and server.+-- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo ( getTypeInfo , TypeInfo(..)+ , Attribute(..) ) where -import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString as B import qualified Data.IntMap as IntMap+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV import Control.Concurrent.MVar import Control.Exception (throw) @@ -27,6 +42,13 @@ import Database.PostgreSQL.Simple.TypeInfo.Types import Database.PostgreSQL.Simple.TypeInfo.Static +-- | Returns the metadata of the type with a particular oid. To find+-- this data, 'getTypeInfo' first consults postgresql-simple's+-- built-in 'staticTypeInfo' table, then checks the connection's+-- typeinfo cache. Finally, the database's 'pg_type' table will+-- be queried only if necessary, and the result will be stored+-- in the connections's cache.+ getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo getTypeInfo conn@Connection{..} oid = case staticTypeInfo oid of@@ -39,25 +61,61 @@ case IntMap.lookup (oid2int oid) oidmap of Just typeinfo -> return (oidmap, typeinfo) Nothing -> do- names <- query conn "SELECT oid, typcategory, typdelim, typname, typelem\+ names <- query conn "SELECT oid, typcategory, typdelim, typname,\+ \ typelem, typrelid\ \ FROM pg_type WHERE oid = ?" (Only oid) (oidmap', typeInfo) <- case names of [] -> return $ throw (fatalError "invalid type oid")- [(typoid, typcategory_, typdelim_, typname, typelem_)] -> do- let !typcategory = B8.index typcategory_ 0- !typdelim = B8.index typdelim_ 0- if typcategory == 'A'- then do+ [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do+ case typcategory of+ 'A' -> do (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap let !typeInfo = Array{..}- return (oidmap', typeInfo)- else do+ return $! (oidmap', typeInfo)+ 'R' -> do+ rngsubtypeOids <- query conn "SELECT rngsubtype\+ \ FROM pg_range\+ \ WHERE rngtypid = ?"+ (Only oid)+ case rngsubtypeOids of+ [Only rngsubtype_] -> do+ (oidmap', rngsubtype) <-+ getTypeInfo' conn rngsubtype_ oidmap+ let !typeInfo = Range{..}+ return $! (oidmap', typeInfo)+ _ -> fail "range subtype query failed to return exactly one result"+ 'C' -> do+ cols <- query conn "SELECT attname, atttypid\+ \ FROM pg_attribute\+ \ WHERE attrelid = ?\+ \ AND attnum > 0\+ \ AND NOT attisdropped\+ \ ORDER BY attnum"+ (Only typrelid)+ vec <- MV.new $! length cols+ (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0+ let !typeInfo = Composite{..}+ return $! (oidmap', typeInfo)+ _ -> do let !typeInfo = Basic{..}- return (oidmap, typeInfo)+ return $! (oidmap, typeInfo) _ -> fail "typename query returned more than one result" -- oid is a primary key, so the query should -- never return more than one result let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap' return $! (oidmap'', typeInfo)++getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache+ -> MV.IOVector Attribute -> Int+ -> IO (TypeInfoCache, V.Vector Attribute)+getAttInfos conn cols oidmap vec n =+ case cols of+ [] -> do+ !attributes <- V.unsafeFreeze vec+ return $! (oidmap, attributes)+ ((attname, attTypeOid):xs) -> do+ (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap+ MV.write vec n $! Attribute{..}+ getAttInfos conn xs oidmap' vec (n+1)
src/Database/PostgreSQL/Simple/TypeInfo/Types.hs view
@@ -12,7 +12,11 @@ import Data.ByteString(ByteString) import Database.PostgreSQL.LibPQ(Oid)+import Data.Vector(Vector) +-- | A structure representing some of the metadata regarding a PostgreSQL+-- type, mostly taken from the @pg_type@ table.+ data TypeInfo = Basic { typoid :: {-# UNPACK #-} !Oid@@ -27,4 +31,26 @@ , typname :: !ByteString , typelem :: !TypeInfo }++ | Range { typoid :: {-# UNPACK #-} !Oid+ , typcategory :: {-# UNPACK #-} !Char+ , typdelim :: {-# UNPACK #-} !Char+ , typname :: !ByteString+ , rngsubtype :: !TypeInfo+ }++ | Composite { typoid :: {-# UNPACK #-} !Oid+ , typcategory :: {-# UNPACK #-} !Char+ , typdelim :: {-# UNPACK #-} !Char+ , typname :: !ByteString+ , typrelid :: {-# UNPACK #-} !Oid+ , attributes :: !(Vector Attribute)+ }+ deriving (Show)++data Attribute+ = Attribute { attname :: !ByteString+ , atttype :: !TypeInfo+ }+ deriving (Show)
test/Main.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE ScopedTypeVariables #-} import Common import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.HStore import Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import Data.Typeable import qualified Data.ByteString as B+import qualified Data.Map as Map+import Data.Text(Text) import System.Exit (exitFailure) import System.IO import qualified Data.Vector as V@@ -23,6 +26,7 @@ , TestLabel "Serializable" . testSerializable , TestLabel "Time" . testTime , TestLabel "Array" . testArray+ , TestLabel "HStore" . testHStore ] testBytea :: TestEnv -> Test@@ -92,7 +96,6 @@ ++ show (typeOf resultType) ++ " -> " ++ show val) - testArray :: TestEnv -> Test testArray TestEnv{..} = TestCase $ do xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"@@ -103,6 +106,16 @@ queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) +testHStore :: TestEnv -> Test+testHStore TestEnv{..} = TestCase $ do+ roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]+ roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]+ where+ roundTrip :: [(Text,Text)] -> Assertion+ roundTrip xs = do+ let m = Only (HStoreMap (Map.fromList xs))+ m' <- query conn "SELECT ?::hstore" m+ [m] @?= m' ------------------------------------------------------------------------