selda-postgresql 0.1.7.2 → 0.1.7.3
raw patch · 4 files changed
+205/−48 lines, 4 filesdep ~selda
Dependency ranges changed: selda
Files
- LICENSE +18/−17
- selda-postgresql.cabal +6/−6
- src/Database/Selda/PostgreSQL.hs +157/−14
- src/Database/Selda/PostgreSQL/Encoding.hs +24/−11
LICENSE view
@@ -1,20 +1,21 @@-Copyright (c) 2017 Anton Ekblad+MIT License -Permission is hereby granted, free of charge, to any person obtaining-a copy of this software and associated documentation files (the-"Software"), to deal in the Software without restriction, including-without limitation the rights to use, copy, modify, merge, publish,-distribute, sublicense, and/or sell copies of the Software, and to-permit persons to whom the Software is furnished to do so, subject to-the following conditions:+Copyright (c) 2017-2018 Anton Ekblad -The above copyright notice and this permission notice shall be included-in all copies or substantial portions of the Software.+Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions: -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.-IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY-CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,-TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE-SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
selda-postgresql.cabal view
@@ -1,5 +1,5 @@ name: selda-postgresql-version: 0.1.7.2+version: 0.1.7.3 synopsis: PostgreSQL backend for the Selda database EDSL. description: PostgreSQL backend for the Selda database EDSL. Requires the PostgreSQL @libpq@ development libraries to be@@ -28,11 +28,11 @@ OverloadedStrings CPP build-depends:- base >=4.8 && <5- , bytestring >=0.9 && <0.11- , exceptions >=0.8 && <0.10- , selda >=0.1.12.1 && <0.2- , text >=1.0 && <1.3+ base >=4.8 && <5+ , bytestring >=0.9 && <0.11+ , exceptions >=0.8 && <0.11+ , selda >=0.3.0.0 && <0.4+ , text >=1.0 && <1.3 if !flag(haste) build-depends: postgresql-libpq >=0.9 && <0.10
src/Database/Selda/PostgreSQL.hs view
@@ -13,6 +13,7 @@ import qualified Data.Text as T import Data.Text.Encoding import Database.Selda.Backend+import Control.Monad (forM_, void) import Control.Monad.Catch import Control.Monad.IO.Class @@ -130,27 +131,31 @@ pgPPConfig :: PPConfig pgPPConfig = defPPConfig- { ppType = pgColType defPPConfig- , ppTypeHook = pgTypeHook- , ppTypePK = pgColTypePK defPPConfig- , ppAutoIncInsert = "DEFAULT"- , ppColAttrs = T.unwords . map pgColAttr- , ppColAttrsHook = pgColAttrsHook- }+ { ppType = pgColType defPPConfig+ , ppTypeHook = pgTypeHook+ , ppTypePK = pgColTypePK defPPConfig+ , ppAutoIncInsert = "DEFAULT"+ , ppColAttrs = T.unwords . map pgColAttr+ , ppColAttrsHook = pgColAttrsHook+ , ppIndexMethodHook = (" USING " <>) . compileIndexMethod+ } where+ compileIndexMethod BTreeIndex = "btree"+ compileIndexMethod HashIndex = "hash"+ pgTypeHook :: SqlTypeRep -> [ColAttr] -> (SqlTypeRep -> T.Text) -> T.Text pgTypeHook ty attrs fun | isGenericIntPrimaryKey ty attrs = pgColTypePK pgPPConfig TRowID | otherwise = fun ty- + pgColAttrsHook :: SqlTypeRep -> [ColAttr] -> ([ColAttr] -> T.Text) -> T.Text pgColAttrsHook ty attrs fun | isGenericIntPrimaryKey ty attrs = fun [Primary] | otherwise = fun $ filter (/= AutoIncrement) attrs- + bigserialQue :: [ColAttr] bigserialQue = [Primary,AutoIncrement,Required,Unique]- + -- For when we use 'autoPrimaryGen' on 'Int' field isGenericIntPrimaryKey :: SqlTypeRep -> [ColAttr] -> Bool isGenericIntPrimaryKey ty attrs = ty == TInt && and ((`elem` attrs) <$> bigserialQue)@@ -163,9 +168,11 @@ , runStmtWithPK = \q ps -> left <$> pgQueryRunner c True q ps , prepareStmt = pgPrepare c , runPrepared = pgRun c+ , getTableInfo = pgGetTableInfo c . rawTableName , backendId = PostgreSQL , ppConfig = pgPPConfig , closeConnection = \_ -> finish c+ , disableForeignKeys = disableFKs c } where left (Left x) = x@@ -173,6 +180,125 @@ right (Right x) = x right _ = error "impossible" +-- Solution to disable FKs from+-- <https://dba.stackexchange.com/questions/96961/how-to-temporarily-disable-foreign-keys-in-amazon-rds-postgresql>+disableFKs :: Connection -> Bool -> IO ()+disableFKs c True = do+ void $ pgQueryRunner c False "BEGIN TRANSACTION;" []+ void $ pgQueryRunner c False create []+ void $ pgQueryRunner c False drop []+ where+ create = mconcat+ [ "create table if not exists __selda_dropped_fks ("+ , " seq bigserial primary key,"+ , " sql text"+ , ");"+ ]+ drop = mconcat+ [ "do $$ declare t record;"+ , "begin"+ , " for t in select conrelid::regclass::varchar table_name, conname constraint_name,"+ , " pg_catalog.pg_get_constraintdef(r.oid, true) constraint_definition"+ , " from pg_catalog.pg_constraint r"+ , " where r.contype = 'f'"+ , " and r.connamespace = (select n.oid from pg_namespace n where n.nspname = current_schema())"+ , " loop"+ , " insert into __selda_dropped_fks (sql) values ("+ , " format('alter table if exists %s add constraint %s %s',"+ , " quote_ident(t.table_name), quote_ident(t.constraint_name), t.constraint_definition));"+ , " execute format('alter table %s drop constraint %s', quote_ident(t.table_name), quote_ident(t.constraint_name));"+ , " end loop;"+ , "end $$;"+ ]+disableFKs c False = do+ void $ pgQueryRunner c False restore []+ void $ pgQueryRunner c False "DROP TABLE __selda_dropped_fks;" []+ void $ pgQueryRunner c False "COMMIT;" []+ where+ restore = mconcat+ [ "do $$ declare t record;"+ , "begin"+ , " for t in select * from __selda_dropped_fks order by seq loop"+ , " execute t.sql;"+ , " delete from __selda_dropped_fks where seq = t.seq;"+ , " end loop;"+ , "end $$;"+ ]++pgGetTableInfo :: Connection -> T.Text -> IO [ColumnInfo]+pgGetTableInfo c tbl = do+ Right (_, vals) <- pgQueryRunner c False tableinfo []+ if null vals+ then do+ pure []+ else do+ Right (_, [[SqlString pk]]) <- pgQueryRunner c False pkquery []+ Right (_, uniques) <- pgQueryRunner c False uniquequery []+ Right (_, fks) <- pgQueryRunner c False fkquery []+ Right (_, ixs) <- pgQueryRunner c False ixquery []+ mapM (describe pk fks (map toText ixs) (map toText uniques)) vals+ where+ toText [SqlString s] = s+ tableinfo = mconcat+ [ "SELECT column_name, data_type, is_nullable "+ , "FROM information_schema.columns "+ , "WHERE table_name = '", tbl, "';"+ ]+ pkquery = mconcat+ [ "SELECT a.attname "+ , "FROM pg_index i "+ , "JOIN pg_attribute a ON a.attrelid = i.indrelid "+ , " AND a.attnum = ANY(i.indkey) "+ , "WHERE i.indrelid = '", tbl, "'::regclass "+ , " AND i.indisprimary;"+ ]+ uniquequery = mconcat+ [ "SELECT a.attname "+ , "FROM pg_index i "+ , "JOIN pg_attribute a ON a.attrelid = i.indrelid "+ , " AND a.attnum = ANY(i.indkey) "+ , "WHERE i.indrelid = '", tbl, "'::regclass "+ , " AND i.indisunique;"+ ]+ fkquery = mconcat+ [ "SELECT kcu.column_name, ccu.table_name, ccu.column_name "+ , "FROM information_schema.table_constraints AS tc "+ , "JOIN information_schema.key_column_usage AS kcu "+ , " ON tc.constraint_name = kcu.constraint_name "+ , "JOIN information_schema.constraint_column_usage AS ccu "+ , " ON ccu.constraint_name = tc.constraint_name "+ , "WHERE constraint_type = 'FOREIGN KEY' AND tc.table_name='", tbl, "';"+ ]+ ixquery = mconcat+ [ "select a.attname as column_name "+ , "from pg_class t, pg_class i, pg_index ix, pg_attribute a "+ , "where "+ , "t.oid = ix.indrelid "+ , "and i.oid = ix.indexrelid "+ , "and a.attrelid = t.oid "+ , "and a.attnum = ANY(ix.indkey) "+ , "and t.relkind = 'r' "+ , "and t.relname = '", tbl , "';"+ ]+ describe pk fks ixs us [SqlString name, SqlString ty, SqlString nullable] =+ return $ ColumnInfo+ { colName = mkColName name+ , colType = mkTypeRep (pk == name) ty'+ , colIsPK = pk == name+ , colIsAutoIncrement = ty' == "bigserial"+ , colIsUnique = name `elem` us+ , colIsNullable = readBool (encodeUtf8 (T.toLower nullable))+ , colHasIndex = name `elem` ixs+ , colFKs =+ [ (mkTableName tbl, mkColName col)+ | [SqlString cname, SqlString tbl, SqlString col] <- fks+ , name == cname+ ]+ }+ where ty' = T.toLower ty+ describe _ _ _ _ results =+ throwM $ SqlError $ "bad result from table info query: " ++ show results+ 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@@ -239,10 +365,10 @@ Just res -> do st <- resultStatus res case st of- BadResponse -> doError c msg- FatalError -> doError c msg- NonfatalError -> doError c msg- _ -> m res+ 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@@ -253,6 +379,22 @@ , maybe "" ((": " ++) . BS.unpack) me ] +mkTypeRep :: Bool -> T.Text -> Either T.Text SqlTypeRep+mkTypeRep True "bigint" = Right TRowID+mkTypeRep True "bigserial" = Right TRowID+mkTypeRep True "int8" = Right TRowID+mkTypeRep _ispk "int8" = Right TInt+mkTypeRep _ispk "bigint" = Right TInt+mkTypeRep _ispk "float8" = Right TFloat+mkTypeRep _ispk "double precision" = Right TFloat+mkTypeRep _ispk "timestamp" = Right TDateTime+mkTypeRep _ispk "bytea" = Right TBlob+mkTypeRep _ispk "text" = Right TText+mkTypeRep _ispk "boolean" = Right TBool+mkTypeRep _ispk "date" = Right TDate+mkTypeRep _ispk "time" = Right TTime+mkTypeRep _ispk typ = Left typ+ -- | Custom column types for postgres. pgColType :: PPConfig -> SqlTypeRep -> T.Text pgColType _ TRowID = "BIGINT"@@ -269,6 +411,7 @@ pgColAttr Required = "NOT NULL" pgColAttr Optional = "NULL" pgColAttr Unique = "UNIQUE"+pgColAttr (Indexed _) = "" -- | Custom column types (primary key position) for postgres. pgColTypePK :: PPConfig -> SqlTypeRep -> T.Text
src/Database/Selda/PostgreSQL/Encoding.hs view
@@ -2,7 +2,7 @@ -- | Encoding/decoding for PostgreSQL. module Database.Selda.PostgreSQL.Encoding ( toSqlValue, fromSqlValue, fromSqlType- , readInt+ , readInt, readBool ) where #ifdef __HASTE__ @@ -17,7 +17,9 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder import Data.ByteString.Char8 (unpack)+import qualified Data.ByteString.Char8 as BSC (map) import qualified Data.ByteString.Lazy as LBS+import Data.Char (toLower) import qualified Data.Text as Text import Data.Text.Encoding import Database.PostgreSQL.LibPQ (Oid (..), Format (..))@@ -25,15 +27,20 @@ import Unsafe.Coerce -- | OIDs for all types used by Selda.-blobType, boolType, intType, textType, doubleType, dateType, timeType, timestampType :: Oid+blobType, boolType, intType, int32Type, int16Type, textType, doubleType,+ dateType, timeType, timestampType, nameType, varcharType :: Oid boolType = Oid 16 intType = Oid 20+int32Type = Oid 23+int16Type = Oid 21 textType = Oid 25+nameType = Oid 19 doubleType = Oid 701 dateType = Oid 1082 timeType = Oid 1083 timestampType = Oid 1114 blobType = Oid 17+varcharType = Oid 1043 -- | Convert a parameter into an postgres parameter triple. fromSqlValue :: Lit a -> Maybe (Oid, BS.ByteString, Format)@@ -64,8 +71,10 @@ -- | 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 == boolType = SqlBool $ readBool (BSC.map toLower val) | t == intType = SqlInt $ readInt val+ | t == int32Type = SqlInt $ readInt val+ | t == int16Type = SqlInt $ readInt val | t == doubleType = SqlFloat $ read (unpack val) | t == blobType = SqlBlob $ pgDecode val | t `elem` textish = SqlString (decodeUtf8 val)@@ -86,14 +95,18 @@ go x | BS.length x >= 2 = (16*hex 0 x + (hex 1 x)) : go (BS.drop 2 x) | otherwise = []- textish = [textType, timestampType, timeType, dateType]- readBool "f" = False- readBool "0" = False- readBool "false" = False- readBool "n" = False- readBool "no" = False- readBool "off" = False- readBool _ = True+ textish = [textType, timestampType, timeType, dateType, nameType, varcharType]++-- | Attempt to make sense of a bool-ish value.+-- Note that values should all be in lowercase.+readBool :: BS.ByteString -> Bool+readBool "f" = False+readBool "0" = False+readBool "false" = False+readBool "n" = False+readBool "no" = False+readBool "off" = False+readBool _ = True -- | Read an integer from a strict bytestring. -- Assumes that the bytestring does, in fact, contain an integer.