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.0 +Version: 0.0.1 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -43,7 +43,7 @@ pcre-light, old-locale, template-haskell, - text >= 0.11.0.2, + text >= 0.11.1, time source-repository head 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 @@ -55,6 +55,7 @@ , Binary(..) , Only(..) -- ** Exceptions + , SqlError(..) , FormatError(fmtMessage, fmtQuery, fmtParams) , QueryError(qeMessage, qeQuery) , ResultError(errSQLType, errHaskellType, errMessage) @@ -67,13 +68,11 @@ -- * Queries that return results , query , query_ -{-- -- * Queries that stream results , fold , fold_ , forEach , forEach_ ---} -- * Statements that do not return results , execute , execute_ @@ -95,30 +94,25 @@ import Control.Applicative ((<$>), pure) import Control.Concurrent.MVar import Control.Exception (Exception, bracket, onException, throw, throwIO) -import Control.Monad (forM) +import Control.Monad (foldM) import Control.Monad.Fix (fix) import Data.ByteString (ByteString) --- import qualified Data.ByteString as B (unpack) import Data.Char(ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap import Data.List (intersperse) import Data.Monoid (mappend, mconcat) import Data.Typeable (Typeable) ---import Database.MySQL.Base (Connection, Result) ---import Database.MySQL.Base.Types (Field) import Database.PostgreSQL.Simple.BuiltinTypes (oid2builtin, builtin2typname) import Database.PostgreSQL.Simple.Param (Action(..), inQuotes) import Database.PostgreSQL.Simple.QueryParams (QueryParams(..)) import Database.PostgreSQL.Simple.Result (ResultError(..)) import Database.PostgreSQL.Simple.QueryResults (QueryResults(..)) --- import Database.PostgreSQL.Simple.Result (ResultError(..)) import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Only(..), Query(..)) import Database.PostgreSQL.Simple.Internal as Base import qualified Database.PostgreSQL.LibPQ as PQ import Text.Regex.PCRE.Light (compile, caseless, match) import qualified Data.ByteString.Char8 as B ---import qualified Database.MySQL.Base as Base -- | Exception thrown if a 'Query' could not be formatted correctly. -- This may occur if the number of \'@?@\' characters in the query @@ -295,7 +289,7 @@ query_ conn q@(Query que) = do result <- exec conn que finishQuery conn q result -{-- + -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. Results are streamed incrementally from the server, and -- consumed via a left fold. @@ -326,11 +320,16 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a -fold conn template qs z f = do - Base.query conn =<< formatQuery conn template qs - finishFold conn template z f ---} -{-- +fold conn template qs z f = withConnection conn $ \c -> do + success <- PQ.sendQuery c =<< formatQuery conn template qs + if success + then finishFold conn c template z f + else do + msg <- maybe "fold error" id <$> PQ.errorMessage c + throwIO $ SqlError { sqlNativeError = -1 + , sqlErrorMsg = msg + , sqlState = "" } + -- | A version of 'fold' that does not perform query substitution. fold_ :: (QueryResults r) => Connection @@ -338,11 +337,16 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a -fold_ conn q@(Query que) z f = do - Base.query conn que - finishFold conn q z f ---} -{-- +fold_ conn q@(Query que) z f = withConnection conn $ \c -> do + success <- PQ.sendQuery c que + if success + then finishFold conn c q z f + else do + msg <- maybe "fold_ error" id <$> PQ.errorMessage c + throwIO $ SqlError { sqlNativeError = -1 + , sqlErrorMsg = msg + , sqlState = "" } + -- | A version of 'fold' that does not transform a state value. forEach :: (QueryParams q, QueryResults r) => Connection @@ -361,7 +365,6 @@ -> IO () forEach_ conn template = fold_ conn template () . const {-# INLINE forEach_ #-} ---} forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] forM' lo hi m = loop hi [] @@ -386,7 +389,7 @@ return Field{..} nrows <- PQ.ntuples result forM' 0 (nrows-1) $ \row -> do - values <- forM' 0 (ncols-1) (\col -> PQ.getvalue' result row col) + values <- forM' 0 (ncols-1) (\col -> PQ.getvalue result row col) case convertResults fields values of Left err -> throwIO err Right a -> return a @@ -401,34 +404,53 @@ , sqlErrorMsg = B.concat [ "query: ", statusmsg , ": ", errormsg ]} -{-- -withResult (Base.storeResult conn) q $ \r fs -> do - status <- -/ flip fix [] $ \loop acc -> do - row <- Base.fetchRow r - case row of - [] -> return (reverse acc) - _ -> let !c = convertResults fs row - in loop (c:acc) ---} -{-- + finishFold :: (QueryResults r) => - Connection -> Query -> a -> (a -> r -> IO a) -> IO a -finishFold conn q z0 f = withResult (Base.useResult conn) q $ \r fs -> - flip fix z0 $ \loop z -> do - row <- Base.fetchRow r - case row of - [] -> return z - _ -> (f z $! convertResults fs row) >>= loop ---} -{-- -withResult :: (IO Result) -> Query -> (Result -> [Field] -> IO a) -> IO a -withResult fetchResult q act = bracket fetchResult Base.freeResult $ \r -> do - ncols <- Base.fieldCount (Right r) - if ncols == 0 - then throwIO $ QueryError "query resulted in zero-column result" q - else act r =<< Base.fetchFields r ---} + Connection + -> PQ.Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +finishFold conn c q a_ f = loop a_ + where + loop a = do + mres <- PQ.getResult c + case mres of + Nothing -> return a + Just result -> do + stat <- PQ.resultStatus result + case stat of + PQ.TuplesOk -> do + ncols <- PQ.nfields result + fields <- forM' 0 (ncols-1) $ \column -> do + type_oid <- PQ.ftype result column + typename <- getTypename conn type_oid + return Field{..} + nrows <- PQ.ntuples result + a' <- foldM (\a row -> do + values <- forM' 0 (ncols-1) (PQ.getvalue result row) + case convertResults fields values of + Left err -> clear c >> throwIO err + Right r -> f a r) + a [0..nrows-1] + loop a' + _ -> do + errormsg <- maybe "" id <$> PQ.resultErrorMessage result + statusmsg <- PQ.resStatus stat + state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate + clear c + throwIO $ SqlError { + sqlState = state, + sqlNativeError = fromEnum stat, + sqlErrorMsg = B.concat [ "fold: ", statusmsg + , ": ", errormsg ]} + clear c = do + mres <- PQ.getResult c + case mres of + Nothing -> return () + Just _ -> clear c + -- | Execute an action inside a SQL transaction. -- -- This function initiates a transaction with a \"@begin diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -90,9 +90,17 @@ connectPostgreSQL :: ByteString -> IO Connection connectPostgreSQL connstr = do conn <- PQ.connectdb connstr - connectionHandle <- newMVar (Just conn) - connectionObjects <- newMVar (IntMap.empty) - return Connection{..} + stat <- PQ.status conn + case stat of + PQ.ConnectionOk -> do + connectionHandle <- newMVar (Just conn) + connectionObjects <- newMVar (IntMap.empty) + return Connection{..} + _ -> do + msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn + throwIO $ SqlError { sqlNativeError = -1 -- FIXME? + , sqlErrorMsg = msg + , sqlState = "" } postgreSQLConnectionString :: ConnectInfo -> ByteString postgreSQLConnectionString connectInfo = fromString connstr diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs --- a/src/Database/PostgreSQL/Simple/LargeObjects.hs +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -11,37 +11,80 @@ ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.LargeObjects - ( loImport + ( loCreat + , loCreate + , loImport + , loImportWithOid , loExport + , loOpen + , loWrite + , loRead + , loSeek + , loTell + , loTruncate + , loClose + , loUnlink , Oid(..) + , LoFd + , IOMode(..) + , SeekMode(..) ) where import Control.Applicative ((<$>)) import Control.Exception (throwIO) -import Database.PostgreSQL.LibPQ (Oid(..)) +import qualified Data.ByteString as B +import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal -import Foreign.C.Types(CInt) +import Foreign.C.Types (CInt) +import System.IO (IOMode(..),SeekMode(..)) -loImport :: Connection -> FilePath -> IO Oid -loImport conn path = withConnection conn $ \c -> do - res <- PQ.loImport c path +liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a +liftPQ str conn m = withConnection conn $ \c -> do + res <- m c case res of Nothing -> do - msg <- maybe "loImport error" id <$> PQ.errorMessage c + msg <- maybe str id <$> PQ.errorMessage c throwIO $ SqlError { sqlNativeError = -1 -- FIXME? , sqlErrorMsg = msg , sqlState = "" } Just x -> return x +loCreat :: Connection -> IO Oid +loCreat conn = liftPQ "loCreat" conn (\c -> PQ.loCreat c) +loCreate :: Connection -> Oid -> IO Oid +loCreate conn oid = liftPQ "loCreate" conn (\c -> PQ.loCreate c oid) + +loImport :: Connection -> FilePath -> IO Oid +loImport conn path = liftPQ "loImport" conn (\c -> PQ.loImport c path) + +loImportWithOid :: Connection -> FilePath -> Oid -> IO Oid +loImportWithOid conn path oid = liftPQ "loImportWithOid" conn (\c -> PQ.loImportWithOid c path oid) + loExport :: Connection -> Oid -> FilePath -> IO () -loExport conn oid path = withConnection conn $ \c -> do - res <- PQ.loExport c oid path - case res of - Nothing -> do - msg <- maybe "loExport error" id <$> PQ.errorMessage c - throwIO $ SqlError { sqlNativeError = -1 -- FIXME? - , sqlErrorMsg = msg - , sqlState = "" } - Just x -> return x +loExport conn oid path = liftPQ "loExport" conn (\c -> PQ.loExport c oid path) + +loOpen :: Connection -> Oid -> IOMode -> IO LoFd +loOpen conn oid mode = liftPQ "loOpen" conn (\c -> PQ.loOpen c oid mode ) + +loWrite :: Connection -> LoFd -> B.ByteString -> IO Int +loWrite conn fd dat = liftPQ "loWrite" conn (\c -> PQ.loWrite c fd dat) + +loRead :: Connection -> LoFd -> Int -> IO B.ByteString +loRead conn fd maxlen = liftPQ "loRead" conn (\c -> PQ.loRead c fd maxlen) + +loSeek :: Connection -> LoFd -> SeekMode -> Int -> IO Int +loSeek conn fd seekmode offset = liftPQ "loSeek" conn (\c -> PQ.loSeek c fd seekmode offset) + +loTell :: Connection -> LoFd -> IO Int +loTell conn fd = liftPQ "loTell" conn (\c -> PQ.loTell c fd) + +loTruncate :: Connection -> LoFd -> Int -> IO () +loTruncate conn fd len = liftPQ "loTruncate" conn (\c -> PQ.loTruncate c fd len) + +loClose :: Connection -> LoFd -> IO () +loClose conn fd = liftPQ "loClose" conn (\c -> PQ.loClose c fd) + +loUnlink :: Connection -> Oid -> IO () +loUnlink conn oid = liftPQ "loUnlink" conn (\c -> PQ.loUnlink c oid) diff --git a/src/Database/PostgreSQL/Simple/Result.hs b/src/Database/PostgreSQL/Simple/Result.hs --- a/src/Database/PostgreSQL/Simple/Result.hs +++ b/src/Database/PostgreSQL/Simple/Result.hs @@ -48,7 +48,7 @@ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Field (Field(..), RawResult(..)) import Database.PostgreSQL.Simple.BuiltinTypes -import Database.PostgreSQL.Simple.Types (Binary(..)) +import Database.PostgreSQL.Simple.Types (Binary(..), Null(..)) import qualified Database.PostgreSQL.LibPQ as PQ import System.IO.Unsafe (unsafePerformIO) import System.Locale (defaultTimeLocale) @@ -82,7 +82,9 @@ instance Exception ResultError -left :: Exception a => a -> Either SomeException b +type Status = Either SomeException + +left :: Exception a => a -> Status b left = Left . SomeException -- | A type that may be converted from a SQL type. @@ -98,6 +100,10 @@ convert _ Nothing = pure Nothing convert f bs = Just <$> convert f bs +instance Result Null where + convert _ Nothing = pure Null + convert f (Just _) = returnError ConversionFailed f "data is not null" + instance Result Bool where convert f bs | typeOid f /= builtin2oid Bool = returnError Incompatible f "" @@ -138,7 +144,7 @@ instance Result SB.ByteString where convert f dat = if typeOid f == builtin2oid Bytea then unBinary <$> convert f dat - else doConvert f okText' pure dat + else doConvert f okText' (pure . B.copy) dat instance Result PQ.Oid where convert f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat @@ -147,7 +153,7 @@ convert f dat = LB.fromChunks . (:[]) <$> convert f dat unescapeBytea :: Field -> SB.ByteString - -> Either SomeException (Binary SB.ByteString) + -> Status (Binary SB.ByteString) unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) @@ -155,16 +161,13 @@ instance Result (Binary SB.ByteString) where convert f dat = case format f of PQ.Text -> doConvert f okBinary (unescapeBytea f) dat - PQ.Binary -> doConvert f okBinary (pure . Binary) dat + PQ.Binary -> doConvert f okBinary (pure . Binary . B.copy) dat instance Result (Binary LB.ByteString) where convert f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> convert f dat instance Result ST.Text where convert f = doConvert f okText $ (either left Right . ST.decodeUtf8') -{- | isText f = doConvert f okText $ (Right . ST.decodeUtf8) - | otherwise = incompatible f (typeOf ST.empty) - "attempt to mix binary and text" -} -- FIXME: check character encoding instance Result LT.Text where @@ -179,30 +182,24 @@ Just t -> Right t Nothing -> returnError ConversionFailed f "could not parse" where ok = mkCompats [TimestampWithTimeZone] -{-- + instance Result Day where - convert f = flip (atto ok) f $ case fieldType f of - Year -> year - _ -> date - where ok = mkCompats [Year,Date,NewDate] - year = fromGregorian <$> decimal <*> pure 1 <*> pure 1 + convert f = atto ok date f + where ok = mkCompats [Date] date = fromGregorian <$> (decimal <* char '-') <*> (decimal <* char '-') <*> decimal instance Result TimeOfDay where - convert f = flip (atto ok) f $ do + convert f = atto' ok time f + where ok = mkCompats [Time] + time = do hours <- decimal <* char ':' mins <- decimal <* char ':' secs <- decimal :: Parser Int case makeTimeOfDayValid hours mins (fromIntegral secs) of - Just t -> return t - _ -> conversionFailed f "TimeOfDay" "could not parse" - where ok = mkCompats [Time] - -isText :: Field -> Bool -isText f = fieldCharSet f /= 63 ---} + Just t -> return (pure t) + _ -> return (returnError ConversionFailed f "could not parse") newtype Compat = Compat Word64 mkCompats :: [BuiltinType] -> Compat @@ -229,8 +226,8 @@ #endif doConvert :: forall a . (Typeable a) - => Field -> Compat -> (ByteString -> Either SomeException a) - -> Maybe ByteString -> Either SomeException a + => Field -> Compat -> (ByteString -> Status a) + -> Maybe ByteString -> Status a doConvert f types cvt (Just bs) | Just typ <- oid2builtin (typeOid f) , mkCompat typ `compat` types = cvt bs @@ -240,20 +237,31 @@ returnError :: forall a err . (Typeable a, Exception err) => (String -> String -> String -> err) - -> Field -> String -> Either SomeException a + -> Field -> String -> Status a returnError mkErr f = left . mkErr (B.unpack (typename f)) (show (typeOf (undefined :: a))) atto :: forall a. (Typeable a) => Compat -> Parser a -> Field -> Maybe ByteString - -> Either SomeException a + -> Status a atto types p0 f dat = doConvert f types (go p0) dat where - go :: Parser a -> ByteString -> Either SomeException a + go :: Parser a -> ByteString -> Status a go p s = case parseOnly p s of Left err -> returnError ConversionFailed f err Right v -> Right v + +atto' :: forall a. (Typeable a) + => Compat -> Parser (Status a) -> Field -> Maybe ByteString + -> Status a +atto' types p0 f dat = doConvert f types (go p0) dat + where + go :: Parser (Status a) -> ByteString -> Status a + go p s = + case parseOnly p s of + Left err -> returnError ConversionFailed f err + Right v -> v instance Result RawResult where convert field rawData = Right (RawResult field rawData)