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.8.0 +Version: 0.3.9.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -59,11 +59,14 @@ blaze-textual, bytestring >= 0.9, containers, + -- hashable is only a workaround for incorrect lower version in uuid + hashable >= 1.2.1.0, postgresql-libpq >= 0.6.2, template-haskell, text >= 0.11.1, time, transformers, + uuid >= 1.3.1, vector extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns @@ -78,7 +81,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.3.8.0 + tag: v0.3.9.0 test-suite test type: exitcode-stdio-1.0 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 @@ -122,6 +122,8 @@ import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT +import Data.UUID (UUID) +import qualified Data.UUID as UUID -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. @@ -443,6 +445,18 @@ parseIt item = (fromField f' . Just . fmt delim) item where f' | Arrays.Array _ <- item = f | otherwise = fElem + +-- | uuid +instance FromField UUID where + fromField f mbs = + if typeOid f /= $(inlineTypoid TI.uuid) + then returnError Incompatible f "" + else case mbs of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case UUID.fromASCIIBytes bs of + Nothing -> returnError ConversionFailed f "Invalid UUID" + Just uuid -> pure uuid -- | json instance FromField JSON.Value where 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, FlexibleInstances #-} ------------------------------------------------------------------------------ -- | @@ -12,7 +12,10 @@ -- returned by a SQL query into a more useful Haskell representation. -- -- Predefined instances are provided for tuples containing up to ten --- elements. +-- elements. The instances for 'Maybe' types return 'Nothing' if all +-- the columns that would have been otherwise consumed are null, otherwise +-- it attempts a regular conversion. +-- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.FromRow @@ -23,25 +26,25 @@ , numFieldsRemaining ) where -import Control.Applicative (Applicative(..), (<$>)) -import Control.Monad (replicateM) +import Prelude hiding (null) +import Control.Applicative (Applicative(..), (<$>), (<|>), (*>)) +import Control.Monad (replicateM, replicateM_) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Vector (Vector) import qualified Data.Vector as V -import Database.PostgreSQL.Simple.Types (Only(..)) +import Database.PostgreSQL.Simple.Types (Only(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Ok -import Database.PostgreSQL.Simple.Types ((:.)(..)) +import Database.PostgreSQL.Simple.Types ((:.)(..), Null) import Database.PostgreSQL.Simple.TypeInfo -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class - -- | 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. -- @@ -120,23 +123,48 @@ column <- lift get return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column) +null :: RowParser Null +null = field + instance (FromField a) => FromRow (Only a) where fromRow = Only <$> field +instance (FromField a) => FromRow (Maybe (Only a)) where + fromRow = (null *> pure Nothing) + <|> (Just <$> fromRow) + instance (FromField a, FromField b) => FromRow (a,b) where fromRow = (,) <$> field <*> field +instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where + fromRow = (null *> null *> pure Nothing) + <|> (Just <$> fromRow) + instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where fromRow = (,,) <$> field <*> field <*> field +instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where + fromRow = (null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) where fromRow = (,,,) <$> field <*> field <*> field <*> field +instance (FromField a, FromField b, FromField c, FromField d) => + FromRow (Maybe (a,b,c,d)) where + fromRow = (null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) where fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field +instance (FromField a, FromField b, FromField c, FromField d, FromField e) => + FromRow (Maybe (a,b,c,d,e)) where + fromRow = (null *> null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a,b,c,d,e,f) where @@ -144,38 +172,83 @@ <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f) => + FromRow (Maybe (a,b,c,d,e,f)) where + fromRow = (null *> null *> null *> null *> null *> + null *> pure Nothing) + <|> (Just <$> fromRow) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (a,b,c,d,e,f,g) where fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g) => + FromRow (Maybe (a,b,c,d,e,f,g)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h) => FromRow (a,b,c,d,e,f,g,h) where fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h) => + FromRow (Maybe (a,b,c,d,e,f,g,h)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i) => FromRow (a,b,c,d,e,f,g,h,i) where fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i) => + FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j) => FromRow (a,b,c,d,e,f,g,h,i,j) where fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j) => + FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + instance FromField a => FromRow [a] where fromRow = do n <- numFieldsRemaining replicateM n field +instance FromField a => FromRow (Maybe [a]) where + fromRow = do + n <- numFieldsRemaining + (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field) + instance FromField a => FromRow (Vector a) where fromRow = do n <- numFieldsRemaining V.replicateM n field + +instance FromField a => FromRow (Maybe (Vector a)) where + fromRow = do + n <- numFieldsRemaining + (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field) instance (FromRow a, FromRow b) => FromRow (a :. b) where fromRow = (:.) <$> fromRow <*> fromRow diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs --- a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | @@ -23,7 +23,9 @@ 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 +#if !MIN_VERSION_bytestring(0,10,0) +import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks) +#endif import Data.Map(Map) import qualified Data.Map as Map import Data.Text(Text) @@ -112,7 +114,7 @@ toField Empty = toField (BS.empty) toField (Comma x) = toField (Blaze.toLazyByteString x) -newtype HStoreList = HStoreList [(Text,Text)] deriving (Typeable, Show) +newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show) -- | hstore instance ToHStore HStoreList where @@ -139,7 +141,7 @@ Right (Right val) -> return val -newtype HStoreMap = HStoreMap (Map Text Text) deriving (Eq, Ord, Typeable, Show) +newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show) instance ToHStore HStoreMap where toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -40,6 +40,8 @@ import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT +import Data.UUID (UUID) +import qualified Data.UUID as UUID import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ @@ -231,6 +233,9 @@ [Plain (fromChar ']')] -- Because the ARRAY[...] input syntax is being used, it is possible -- that the use of type-specific separator characters is unnecessary. + +instance ToField UUID where + toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes instance ToField JSON.Value where toField = toField . JSON.encode diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs --- a/src/Database/PostgreSQL/Simple/Transaction.hs +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -36,7 +36,6 @@ ) where import qualified Control.Exception as E -import Data.ByteString (ByteString) import qualified Data.ByteString as B import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -109,7 +109,7 @@ deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap binary data for use as a @bytea@ value. -newtype Binary a = Binary a +newtype Binary a = Binary {fromBinary :: a} deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | A composite type to parse your custom data structures without