packages feed

postgresql-simple 0.0 → 0.0.1

raw patch · 5 files changed

+177/−96 lines, 5 filesdep ~text

Dependency ranges changed: text

Files

postgresql-simple.cabal view
@@ -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
src/Database/PostgreSQL/Simple.hs view
@@ -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
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -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
src/Database/PostgreSQL/Simple/LargeObjects.hs view
@@ -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)
src/Database/PostgreSQL/Simple/Result.hs view
@@ -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)