Commit a3a1a67d authored by Sophie Herold's avatar Sophie Herold 🌼

Fixes bugs in inquirey with quoted names

parent 27ab3632
Pipeline #817 passed with stage
in 3 minutes and 58 seconds
......@@ -28,12 +28,12 @@ type SqlT = ReaderT Connection IO
psqlQry :: (ToRow q, FromRow r) => Query -> q -> SqlT [r]
psqlQry template qs = do
conn <- ask
lift $ query conn template qs
lift (query conn template qs `catch` psqlHandleErr template)
psqlQry_ :: (FromRow r) => Query -> SqlT [r]
psqlQry_ que = do
conn <- ask
lift $ query_ conn que
lift (query_ conn que `catch` psqlHandleErr que)
sqlErrObjectInUse :: B.ByteString
sqlErrObjectInUse = "55006"
......@@ -99,7 +99,30 @@ pgsqlConnectUrl url = do
showCode (decodeUtf8 (sqlErrorMsg e))
Right conn -> conn
pgsqlHandleErr :: SqlStmt -> Connection -> SqlError -> IO ()
psqlHandleErr :: Query -> SqlError -> IO a
psqlHandleErr stmt e =
err $
"An SQL error occured while executing the following statement" <>
showCode (tshow stmt) <\>
"The SQL-Server reported" <\>
"Message:" <>
showCode (decodeUtf8 (sqlErrorMsg e)) <\>
"Code: " <>
showCode (decodeUtf8 (sqlState e)) <\>
errDetail <\>
errHint <\>
"\nAll statements have been rolled back if possible."
where
errDetail =
case sqlErrorDetail e of
"" -> ""
x -> "Detail:" <> showCode (decodeUtf8 x)
errHint =
case sqlErrorHint e of
"" -> ""
x -> "Hint:" <> showCode (decodeUtf8 x)
pgsqlHandleErr :: SqlStmt -> Connection -> SqlError -> IO a
pgsqlHandleErr stmt conn e = do
extraMsg <-
if sqlState e == sqlErrObjectInUse && stmtIdType stmt == SqlDropDatabase
......@@ -115,8 +138,7 @@ pgsqlHandleErr stmt conn e = do
(map showConnected $
filter (\(db, _, _) -> toSqlCode db == sqlIdCode stmt) xs)
else return ""
_ <-
err $
err $
"An SQL error occured while executing the following statement" <>
showCode (toSqlCode stmt) <\>
"The SQL-Server reported" <\>
......@@ -128,7 +150,6 @@ pgsqlHandleErr stmt conn e = do
errHint <\>
extraMsg <\>
"\nAll statements have been rolled back if possible."
return ()
where
showConnected (_, role, app) = " - role" <-> toSqlCode role <> appOut app
appOut "" = ""
......
......@@ -78,7 +78,7 @@ deployedTables schema = do
return
Table
{ tableName = table
, tableDescription = description
, tableDescription = fromMaybe "" description
, tableColumns = columns
, tablePrimaryKey = pk
, tableUnique = presetEmpty uniques
......@@ -94,11 +94,12 @@ deployedTables schema = do
qry =
[sql|
SELECT
table_name,
COALESCE(pg_catalog.obj_description(
(table_schema || '.' || table_name)::regclass, 'pg_class'), '')
FROM information_schema.tables
WHERE table_schema::regnamespace = ?::regnamespace
relname,
pg_catalog.obj_description(oid, 'pg_class') AS desc
FROM pg_catalog.pg_class
WHERE
relkind = 'r'
AND relnamespace = ?::regnamespace::oid
|]
deployedColumns :: (SqlName, SqlName) -> SqlT [Column]
......@@ -108,7 +109,7 @@ deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
Column
{ columnName = sname
, columnType = dataType
, columnDescription = description
, columnDescription = fromMaybe "" description
, columnDefault = columnDefault'
, columnNull = preset False isNullable
, columnReferences = Nothing
......@@ -120,16 +121,18 @@ deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
qry =
[sql|
SELECT
column_name,
COALESCE(domain_schema || '.' || domain_name, data_type),
column_default,
is_nullable::bool,
COALESCE(pg_catalog.col_description(a.attrelid, a.attnum), '')
FROM information_schema.columns
JOIN pg_catalog.pg_attribute AS a
ON a.attrelid = (table_schema || '.' || table_name)::regclass
AND a.attname = column_name
WHERE (table_schema || '.' || table_name)::regclass = ?::regclass
attname,
atttypid::regtype::text,
def.adsrc,
NOT attnotnull,
pg_catalog.col_description(attrelid, attnum)
FROM pg_catalog.pg_attribute
LEFT JOIN pg_catalog.pg_attrdef AS def
ON attrelid = adrelid AND adnum = attnum
WHERE
NOT attisdropped
AND attnum > 0
AND attrelid = ?::regclass::oid
|]
--deployedKeys ::
......@@ -211,7 +214,7 @@ keyQuery =
JOIN pg_attribute AS a
ON trel.oid = a.attrelid AND a.attnum = c.colnum
WHERE
(tnsp.nspname || '.' || trel.relname)::regclass = ?::regclass
trel.oid::regclass = ?::regclass
AND i.indisunique = ?
AND i.indisprimary = ?
GROUP BY tnsp.nspname, trel.relname, irel.relname;
......@@ -229,33 +232,32 @@ toVariable varType varName varDefault =
deployedFunctions :: SqlName -> SqlT [Function]
deployedFunctions schema = do
funs <- psqlQry qry (Only $ toSqlCode schema)
mapM toFunction funs
return $ map toFunction funs
where
toFunction (proname, description, prorettype, proargnames, proargtypes, proargdefaults, owner, language, prosecdef, source) = do
return
Function
{ functionName = proname
, functionDescription = fromMaybe "" description
, functionReturns = prorettype
, functionParameters =
let n = length $ fromPGArray proargtypes
def = fromMaybe (replicate n Nothing)
in presetEmpty $
zipWith3
toVariable
(fromPGArray proargtypes)
(def $ fromPGArray <$> proargnames)
(def $ fromPGArray <$> proargdefaults)
, functionTemplates = Nothing
, functionTemplateData = Nothing
, functionReturnsColumns = Nothing
, functionVariables = Nothing
, functionPrivExecute = Nothing
, functionSecurityDefiner = preset False prosecdef
, functionOwner = owner
, functionLanguage = Just language
, functionBody = source
}
toFunction (proname, description, prorettype, proargnames, proargtypes, proargdefaults, owner, language, prosecdef, source) =
Function
{ functionName = proname
, functionDescription = fromMaybe "" description
, functionReturns = prorettype
, functionParameters =
let n = length $ fromPGArray proargtypes
def = fromMaybe (replicate n Nothing)
in presetEmpty $
zipWith3
toVariable
(fromPGArray proargtypes)
(def $ fromPGArray <$> proargnames)
(def $ fromPGArray <$> proargdefaults)
, functionTemplates = Nothing
, functionTemplateData = Nothing
, functionReturnsColumns = Nothing
, functionVariables = Nothing
, functionPrivExecute = Nothing
, functionSecurityDefiner = preset False prosecdef
, functionOwner = owner
, functionLanguage = Just language
, functionBody = source
}
qry =
[sql|
SELECT
......
......@@ -128,10 +128,10 @@ readSchema md = do
let schemaData' =
schemaData
{ schemaDomains = schemaDomains schemaData <> presetEmpty domains
, schemaTypes = schemaTypes schemaData <> presetEmpty types
, schemaFunctions = schemaFunctions schemaData <> presetEmpty functions
, schemaSequences = schemaSequences schemaData <> presetEmpty sequences
, schemaTables = schemaTables schemaData <> presetEmpty tables
, schemaFunctions = schemaFunctions schemaData <> presetEmpty functions
, schemaTypes = schemaTypes schemaData <> presetEmpty types
}
return schemaData'
where
......
......@@ -7,6 +7,7 @@ module Database.HamSql.Write
import qualified Data.ByteString as B
import Data.Ord (comparing)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml
import Data.Yaml.Pretty
import System.Directory.Tree
......@@ -16,20 +17,41 @@ import Database.YamSql
schemaToDirTree :: Schema -> DirTree B.ByteString
schemaToDirTree schema =
Dir
(filePath $ schemaName schema)
([File "schema.yml" (toYml schema {schemaTables = Nothing})] ++
catMaybes
[Dir "tables.d" . map (toFile tableName) <$> (schemaTables schema)])
let schemaFile =
File
"schema.yml"
(toYml schema {schemaTables = Nothing, schemaFunctions = Nothing})
in Dir
(filePath $ schemaName schema)
(schemaFile :
catMaybes
[ Dir "domains.d" . map (toYamlFile domainName) <$>
schemaDomains schema
, Dir "sequences.d" . map (toYamlFile sequenceName) <$>
schemaSequences schema
, Dir "types.d" . map (toYamlFile typeName) <$> schemaTypes schema
, Dir "functions.d" .
map
(\x ->
toFrontmatterFile
functionName
(x {functionBody = Nothing})
(functionBody x)) <$>
schemaFunctions schema
])
where
toFile getName obj = File (filePath $ getName obj) (toYml obj)
toYamlFile getName obj = File (filePath (getName obj) <> ".yml") (toYml obj)
toFrontmatterFile getName obj src =
File
(filePath (getName obj) <> ".sql")
("---\n" <> toYml obj <> "---\n" <> encodeUtf8 (fromMaybe "" src))
filePath :: SqlName -> FilePath
filePath = T.unpack . T.replace "\"" "" . unsafePlainName
toYml :: ToJSON a => a -> B.ByteString
toYml =
encodePretty $
(setConfCompare $ comparing ymlOrd) $ (setConfDropNull True) defConfig
setConfCompare (comparing ymlOrd) $ (setConfDropNull True) defConfig
doWrite :: FilePath -> DirTree B.ByteString -> IO (AnchoredDirTree ())
doWrite p x = writeDirectoryWith B.writeFile (p :/ x)
......
name: self-test
description: Table Install
tables:
- name: "x"
description: Table ``x`` without primary_key
primary_key: []
columns:
- name: x1
type: integer
description: Column x1
- name: x2
type: integer
description: Column x2
- name: x3
type: integer
description: Column x3
unique:
- name:
# TODO: customPrefix_u2 fails
prefixed: customprefix_u2
columns: [x1]
- name: u1
columns: [x1]
- [x1]
- [x1, x3]
- name: "y"
description: Table ``y``
primary_key: [y1]
columns:
- name: y1
type: integer
description: Column y1
- name: y2
type: integer
description: Column y2
foreign_keys:
- name: manualfk
columns: [y1, y2]
ref_table: '"self-test".x'
ref_columns: [x1, x3]
description: Self Test
name: "X"
description: Table ``X`` without primary_key
primary_key: []
columns:
- name: X3
type: integer
description: Column X3
- name: x1
type: integer
description: Column x1
- name: x2
type: integer
description: Column x2
unique:
- name:
prefixed: CustomPrefix_u2
columns: [x1]
- name: u1
columns: [x1]
- [x1, X3]
- [x1]
name: "y"
description: Table ``y``
primary_key: [y1]
columns:
- name: y1
type: integer
description: Column y1
- name: y2
type: integer
description: Column y2
foreign_keys:
- name: manualfk
columns: [y1, y2]
ref_table: '"self-test"."X"'
ref_columns: [X3, x1]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment