selda-postgresql 0.1.4.0 → 0.1.5.0

raw patch · 3 files changed

+142/−59 lines, 3 filesdep +transformersdep ~seldaPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: transformers

Dependency ranges changed: selda

API changes (from Hackage documentation)

Files

• selda-postgresql.cabal +5/−2
• src/Database/Selda/PostgreSQL.hs +101/−53
• src/Database/Selda/PostgreSQL/Encoding.hs +36/−4

@@ -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:

@@ -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

@@ -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