diff --git a/selda-postgresql.cabal b/selda-postgresql.cabal --- a/selda-postgresql.cabal +++ b/selda-postgresql.cabal @@ -1,5 +1,5 @@ name: selda-postgresql -version: 0.1.4.0 +version: 0.1.5.0 synopsis: PostgreSQL backend for the Selda database EDSL. description: PostgreSQL backend for the Selda database EDSL. Requires the PostgreSQL @libpq@ development libraries to be @@ -30,12 +30,15 @@ build-depends: base >=4.8 && <5 , exceptions >=0.8 && <0.9 - , selda >=0.1.7.0 && <0.2 + , selda >=0.1.8.0 && <0.2 , text >=1.0 && <1.3 if !flag(haste) build-depends: bytestring >=0.9 && <0.11 , postgresql-libpq >=0.9 && <0.10 + if impl(ghc < 7.11) + build-depends: + transformers >=0.4 && <0.6 hs-source-dirs: src default-language: diff --git a/src/Database/Selda/PostgreSQL.hs b/src/Database/Selda/PostgreSQL.hs --- a/src/Database/Selda/PostgreSQL.hs +++ b/src/Database/Selda/PostgreSQL.hs @@ -3,14 +3,16 @@ module Database.Selda.PostgreSQL ( PGConnectInfo (..) , withPostgreSQL, on, auth - , pgBackend + , pgOpen, seldaClose , pgConnString ) where +import Data.Dynamic import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding import Database.Selda.Backend import Control.Monad.Catch +import Control.Monad.IO.Class #ifndef __HASTE__ import Database.Selda.PostgreSQL.Encoding @@ -70,13 +72,21 @@ withPostgreSQL _ _ = return $ error "withPostgreSQL called in JS context" #else withPostgreSQL ci m = do + c <- pgOpen ci + runSeldaT m c `finally` seldaClose c + +-- | Open a new PostgreSQL connection. The connection will persist across +-- calls to 'runSeldaT', and must be explicitly closed using 'seldaClose' +-- when no longer needed. +pgOpen :: (MonadIO m, MonadThrow m) => PGConnectInfo -> m SeldaConnection +pgOpen ci = do conn <- liftIO $ connectdb connstr st <- liftIO $ status conn case st of ConnectionOk -> do - let backend = pgBackend (decodeUtf8 connstr) conn + let backend = pgBackend conn liftIO $ runStmt backend "SET client_min_messages TO WARNING;" [] - runSeldaT m backend `finally` liftIO (finish conn) + newConnection backend (decodeUtf8 connstr) nope -> do connFailed nope where @@ -86,16 +96,20 @@ ] -- | Create a `SeldaBackend` for PostgreSQL `Connection` -pgBackend :: T.Text -- ^ Unique database identifier. Preferably the - -- connection string used to open the connection. - -> Connection -- ^ PostgreSQL connection object. +pgBackend :: Connection -- ^ PostgreSQL connection object. -> SeldaBackend -pgBackend ident c = SeldaBackend - { runStmt = \q ps -> right <$> pgQueryRunner c False q ps - , runStmtWithPK = \q ps -> left <$> pgQueryRunner c True q ps - , customColType = pgColType - , defaultKeyword = "DEFAULT" - , dbIdentifier = ident +pgBackend c = SeldaBackend + { runStmt = \q ps -> right <$> pgQueryRunner c False q ps + , runStmtWithPK = \q ps -> left <$> pgQueryRunner c True q ps + , prepareStmt = pgPrepare c + , runPrepared = pgRun c + , backendId = PostgreSQL + , ppConfig = defPPConfig + { ppType = pgColType defPPConfig + , ppAutoIncInsert = "DEFAULT" + , ppColAttrs = ppColAttrs defPPConfig . filter (/= AutoIncrement) + } + , closeConnection = \_ -> finish c } where left (Left x) = x @@ -122,16 +136,10 @@ pgQueryRunner :: Connection -> Bool -> T.Text -> [Param] -> IO (Either Int (Int, [[SqlValue]])) pgQueryRunner c return_lastid q ps = do mres <- execParams c (encodeUtf8 q') [fromSqlValue p | Param p <- ps] Text - case mres of - Just res -> do - st <- resultStatus res - case st of - BadResponse -> throwM $ SqlError "bad response" - FatalError -> throwM $ SqlError errmsg - NonfatalError -> throwM $ SqlError errmsg - _ | return_lastid -> Left <$> getLastId res - | otherwise -> Right <$> getRows res - Nothing -> throwM $ DbError "unable to submit query to server" + unlessError c errmsg mres $ \res -> do + if return_lastid + then Left <$> getLastId res + else Right <$> getRows res where errmsg = "error executing query `" ++ T.unpack q' ++ "'" q' | return_lastid = q <> " RETURNING LASTVAL();" @@ -139,38 +147,78 @@ getLastId res = (readInt . maybe "0" id) <$> getvalue res 0 0 - getRows res = do - rows <- ntuples res - cols <- nfields res - types <- mapM (ftype res) [0..cols-1] - affected <- cmdTuples res - result <- mapM (getRow res types cols) [0..rows-1] - pure $ case affected of - Just "" -> (0, result) - Just s -> (readInt s, result) - _ -> (0, result) +pgRun :: Connection -> Dynamic -> [Param] -> IO (Int, [[SqlValue]]) +pgRun c hdl ps = do + let Just sid = fromDynamic hdl :: Maybe StmtID + mres <- execPrepared c (BS.pack $ show sid) (map mkParam ps) Text + unlessError c errmsg mres $ getRows + where + errmsg = "error executing prepared statement" + mkParam (Param p) = case fromSqlValue p of + Just (_, val, fmt) -> Just (val, fmt) + Nothing -> Nothing - getRow res types cols row = do - sequence $ zipWith (getCol res row) [0..cols-1] types +-- | Get all rows from a result. +getRows :: Result -> IO (Int, [[SqlValue]]) +getRows res = do + rows <- ntuples res + cols <- nfields res + types <- mapM (ftype res) [0..cols-1] + affected <- cmdTuples res + result <- mapM (getRow res types cols) [0..rows-1] + pure $ case affected of + Just "" -> (0, result) + Just s -> (readInt s, result) + _ -> (0, result) - getCol res row col t = do - mval <- getvalue res row col - case mval of - Just val -> pure $ toSqlValue t val - _ -> pure SqlNull +-- | Get all columns for the given row. +getRow :: Result -> [Oid] -> Column -> Row -> IO [SqlValue] +getRow res types cols row = do + sequence $ zipWith (getCol res row) [0..cols-1] types --- | Custom column types for postgres: auto-incrementing primary keys need to --- be @BIGSERIAL@, and ints need to be @INT8@. -pgColType :: T.Text -> [ColAttr] -> Maybe T.Text -pgColType "INTEGER" attrs - | AutoIncrement `elem` attrs = - Just "BIGSERIAL PRIMARY KEY NOT NULL" - | otherwise = - Just $ T.unwords ("INT8" : map compileColAttr attrs) -pgColType "DOUBLE" attrs = - Just $ T.unwords ("FLOAT8" : map compileColAttr attrs) -pgColType "DATETIME" attrs = - Just $ T.unwords ("TIMESTAMP" : map compileColAttr attrs) -pgColType _ _ = - Nothing +-- | Get the given column. +getCol :: Result -> Row -> Column -> Oid -> IO SqlValue +getCol res row col t = do + mval <- getvalue res row col + case mval of + Just val -> pure $ toSqlValue t val + _ -> pure SqlNull + +pgPrepare :: Connection -> StmtID -> [SqlTypeRep] -> T.Text -> IO Dynamic +pgPrepare c sid types q = do + mres <- prepare c (BS.pack $ show sid) (encodeUtf8 q) (Just types') + unlessError c errmsg mres $ \_ -> return (toDyn sid) + where + types' = map fromSqlType types + errmsg = "error preparing query `" ++ T.unpack q ++ "'" + +-- | Perform the given computation unless an error occurred previously. +unlessError :: Connection -> String -> Maybe Result -> (Result -> IO a) -> IO a +unlessError c msg mres m = do + case mres of + Just res -> do + st <- resultStatus res + case st of + BadResponse -> doError c msg + FatalError -> doError c msg + NonfatalError -> doError c msg + _ -> m res + Nothing -> throwM $ DbError "unable to submit query to server" + +doError :: Connection -> String -> IO a +doError c msg = do + me <- errorMessage c + throwM $ SqlError $ concat + [ msg + , maybe "" ((": " ++) . BS.unpack) me + ] + +-- | Custom column types for postgres. +pgColType :: PPConfig -> SqlTypeRep -> T.Text +pgColType _ TRowID = "BIGSERIAL" +pgColType _ TInt = "INT8" +pgColType _ TFloat = "FLOAT8" +pgColType _ TDateTime = "TIMESTAMP" +pgColType _ TBlob = "BYTEA" +pgColType cfg t = ppType cfg t #endif diff --git a/src/Database/Selda/PostgreSQL/Encoding.hs b/src/Database/Selda/PostgreSQL/Encoding.hs --- a/src/Database/Selda/PostgreSQL/Encoding.hs +++ b/src/Database/Selda/PostgreSQL/Encoding.hs @@ -1,20 +1,22 @@ {-# LANGUAGE GADTs, BangPatterns, OverloadedStrings #-} -- | Encoding/decoding for PostgreSQL. module Database.Selda.PostgreSQL.Encoding - ( toSqlValue, fromSqlValue + ( toSqlValue, fromSqlValue, fromSqlType , readInt ) where +import Control.Exception (throw) import qualified Data.ByteString as BS import Data.ByteString.Builder import Data.ByteString.Char8 (unpack) import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text import Data.Text.Encoding import Database.PostgreSQL.LibPQ (Oid (..), Format (..)) -import Database.Selda.Backend (Lit (..), SqlValue (..)) +import Database.Selda.Backend import Unsafe.Coerce -- | OIDs for all types used by Selda. -boolType, intType, textType, doubleType, dateType, timeType, timestampType :: Oid +blobType, boolType, intType, textType, doubleType, dateType, timeType, timestampType :: Oid boolType = Oid 16 intType = Oid 20 textType = Oid 25 @@ -22,29 +24,59 @@ dateType = Oid 1082 timeType = Oid 1083 timestampType = Oid 1114 +blobType = Oid 17 -- | Convert a parameter into an postgres parameter triple. fromSqlValue :: Lit a -> Maybe (Oid, BS.ByteString, Format) fromSqlValue (LBool b) = Just (boolType, toBS $ if b then word8 1 else word8 0, Binary) fromSqlValue (LInt n) = Just (intType, toBS $ int64BE (fromIntegral n), Binary) fromSqlValue (LDouble f) = Just (doubleType, toBS $ int64BE (unsafeCoerce f), Binary) -fromSqlValue (LText s) = Just (textType, encodeUtf8 s, Text) +fromSqlValue (LText s) = Just (textType, encodeUtf8 $ Text.filter (/= '\0') s, Binary) fromSqlValue (LDateTime s) = Just (timestampType, encodeUtf8 s, Text) fromSqlValue (LTime s) = Just (timeType, encodeUtf8 s, Text) fromSqlValue (LDate s) = Just (dateType, encodeUtf8 s, Text) +fromSqlValue (LBlob b) = Just (blobType, b, Binary) fromSqlValue (LNull) = Nothing fromSqlValue (LJust x) = fromSqlValue x fromSqlValue (LCustom l) = fromSqlValue l +-- | Get the corresponding OID for an SQL type representation. +fromSqlType :: SqlTypeRep -> Oid +fromSqlType TBool = boolType +fromSqlType TInt = intType +fromSqlType TFloat = doubleType +fromSqlType TText = textType +fromSqlType TDateTime = timestampType +fromSqlType TDate = dateType +fromSqlType TTime = timeType +fromSqlType TBlob = blobType +fromSqlType TRowID = intType + -- | Convert the given postgres return value and type to an @SqlValue@. toSqlValue :: Oid -> BS.ByteString -> SqlValue toSqlValue t val | t == boolType = SqlBool $ readBool val | t == intType = SqlInt $ readInt val | t == doubleType = SqlFloat $ read (unpack val) + | t == blobType = SqlBlob $ pgDecode val | t `elem` textish = SqlString (decodeUtf8 val) | otherwise = error $ "BUG: result with unknown type oid: " ++ show t where + -- PostgreSQL hex strings are of the format \xdeadbeefdeadbeefdeadbeef... + pgDecode s + | BS.index s 0 == 92 && BS.index s 1 == 120 = + BS.pack $ go $ BS.drop 2 s + | otherwise = + error $ "bad blob string from postgres: " ++ show s + where + hex n s = + case BS.index s n of + c | c >= 97 -> c - 87 -- c >= 'a' + | c >= 65 -> c - 55 -- c >= 'A' + | otherwise -> c - 48 -- c is numeric + go s + | BS.length s >= 2 = (16*hex 0 s + (hex 1 s)) : go (BS.drop 2 s) + | otherwise = [] textish = [textType, timestampType, timeType, dateType] readBool "f" = False readBool "0" = False