diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. 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.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 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 @@ -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 +-- +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 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 @@ -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.