diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -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 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -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) diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/FromField.hs-boot b/src/Database/PostgreSQL/Simple/FromField.hs-boot --- a/src/Database/PostgreSQL/Simple/FromField.hs-boot +++ b/src/Database/PostgreSQL/Simple/FromField.hs-boot @@ -6,5 +6,6 @@ class FromField a instance FromField Oid +instance FromField Char instance FromField ByteString instance FromField a => FromField (Maybe a) diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -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 } diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs-boot b/src/Database/PostgreSQL/Simple/FromRow.hs-boot --- a/src/Database/PostgreSQL/Simple/FromRow.hs-boot +++ b/src/Database/PostgreSQL/Simple/FromRow.hs-boot @@ -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) + diff --git a/src/Database/PostgreSQL/Simple/HStore.hs b/src/Database/PostgreSQL/Simple/HStore.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore.hs @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.HStore +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- 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 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 +-- for more +-- information. +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.HStore + ( HStoreList(..) + , HStoreMap(..) + , ToHStore(..) + , HStoreBuilder + , toBuilder + , toLazyByteString + , hstore + , ToHStoreText(..) + , HStoreText + ) where + +import Database.PostgreSQL.Simple.HStore.Implementation diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -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 +-- 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 '"' diff --git a/src/Database/PostgreSQL/Simple/HStore/Internal.hs b/src/Database/PostgreSQL/Simple/HStore/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore/Internal.hs @@ -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 +-- Stability: experimental +-- Portability: portable +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.HStore.Internal + ( HStoreBuilder(..) + , HStoreText(..) + , parseHStore + , parseHStoreKeyVal + , parseHStoreText + ) where + +import Database.PostgreSQL.Simple.HStore.Implementation diff --git a/src/Database/PostgreSQL/Simple/TypeInfo.hs b/src/Database/PostgreSQL/Simple/TypeInfo.hs --- a/src/Database/PostgreSQL/Simple/TypeInfo.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo.hs @@ -8,15 +8,30 @@ -- Maintainer: Leon P Smith -- 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) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs --- a/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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' ------------------------------------------------------------------------