diff options
author | Adam Chlipala <adam@chlipala.net> | 2014-01-04 19:02:14 -0500 |
---|---|---|
committer | Adam Chlipala <adam@chlipala.net> | 2014-01-04 19:02:14 -0500 |
commit | 771723435b7949b0a0ccb1e55ce919994a97613f (patch) | |
tree | 094c7e8aa2ab521cce351f856ca80f42e5bc77b0 /src | |
parent | d7c4eb5eb07091dfa292943c8a6825a2ec7f244c (diff) |
noMangleSql .urp directive
Diffstat (limited to 'src')
-rw-r--r-- | src/compiler.sml | 1 | ||||
-rw-r--r-- | src/monoize.sml | 62 | ||||
-rw-r--r-- | src/mysql.sml | 57 | ||||
-rw-r--r-- | src/postgres.sml | 25 | ||||
-rw-r--r-- | src/settings.sig | 9 | ||||
-rw-r--r-- | src/settings.sml | 20 |
6 files changed, 110 insertions, 64 deletions
diff --git a/src/compiler.sml b/src/compiler.sml index b2635e5e..5e60288b 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -864,6 +864,7 @@ fun parseUrp' accLibs fname = | "alwaysInline" => Settings.addAlwaysInline arg | "noXsrfProtection" => Settings.addNoXsrfProtection arg | "timeFormat" => Settings.setTimeFormat arg + | "noMangleSql" => Settings.setMangleSql false | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () diff --git a/src/monoize.sml b/src/monoize.sml index aeb99d94..000ba7b6 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1624,7 +1624,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EPrim (Prim.String (String.concatWith ", " (map (fn (x, _) => - "uw_" ^ monoNameLc env x + Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then "(767)" @@ -1668,7 +1668,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EPrim (Prim.String ("UNIQUE (" ^ String.concatWith ", " - (map (fn (x, t) => "uw_" ^ monoNameLc env x + (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then "(767)" @@ -1714,19 +1714,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("m", mat, mat, (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), [((L'.PPrim (Prim.String ""), loc), - (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)), + (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))), loc), string), - ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)), + ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))), loc), string)], loc)), ((L'.PWild, loc), (L'.ERecord [("1", (L'.EStrcat ( - (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1 + (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1) ^ ", ")), loc), (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( - (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2 + (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2) ^ ", ")), loc), (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)], @@ -1857,7 +1857,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = strcat [sc "INSERT INTO ", (L'.ERel 1, loc), sc " (", - strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields), + strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields), sc ") VALUES (", strcatComma (map (fn (x, _) => (L'.EField ((L'.ERel 0, loc), @@ -1884,7 +1884,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 1, loc), sc " AS T_T SET ", strcatComma (map (fn (x, _) => - strcat [sc ("uw_" ^ x + strcat [sc (Settings.mangleSql x ^ " = "), (L'.EField ((L'.ERel 2, @@ -1898,7 +1898,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 1, loc), sc " SET ", strcatComma (map (fn (x, _) => - strcat [sc ("uw_" ^ x + strcat [sc (Settings.mangleSql x ^ " = "), (L'.EFfiApp ("Basis", "unAs", [((L'.EField @@ -2090,14 +2090,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc), - sc (" AS uw_" ^ x) + sc (" AS " ^ Settings.mangleSql x) ]) sexps @ map (fn (x, xts) => strcatComma (map (fn (x', _) => sc ("T_" ^ x - ^ ".uw_" - ^ x')) + ^ "." + ^ Settings.mangleSql x')) xts)) stables), (L'.ECase (gf "From", [((L'.PPrim (Prim.String ""), loc), @@ -2131,8 +2131,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = strcatComma (map (fn (x', _) => sc ("T_" ^ x - ^ ".uw_" - ^ x')) + ^ "" + ^ Settings.mangleSql x')) xts)) grouped) ], @@ -2626,7 +2626,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), (L.CName tab, _)), _), - (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm) + (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm) | L.ECApp ( (L.ECApp ( @@ -2638,7 +2638,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), _), _), - (L.CName nm, _)) => ((L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm)), loc), fm) + (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm) | L.ECApp ( (L.ECApp ( @@ -4368,7 +4368,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) - val s = "uw_" ^ s + val s = Settings.mangleSqlTable s val e_name = (L'.EPrim (Prim.String s), loc) val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts @@ -4386,7 +4386,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) - val s = "uw_" ^ s + val s = Settings.mangleSqlTable s val e_name = (L'.EPrim (Prim.String s), loc) val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts @@ -4404,7 +4404,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) - val s = "uw_" ^ s + val s = Settings.mangleSql s val e = (L'.EPrim (Prim.String s), loc) in SOME (Env.pushENamed env x n t NONE s, @@ -4553,7 +4553,7 @@ fun monoize env file = val (nullable, notNullable) = calcClientish xts fun cond (x, v) = - (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x + (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x ^ (case v of Client => "" | Channel => " >> 32") @@ -4564,10 +4564,10 @@ fun monoize env file = foldl (fn ((x, v), e) => (L'.ESeq ( (L'.EDml ((L'.EStrcat ( - (L'.EPrim (Prim.String ("UPDATE uw_" - ^ tab - ^ " SET uw_" - ^ x + (L'.EPrim (Prim.String ("UPDATE " + ^ Settings.mangleSql tab + ^ " SET " + ^ Settings.mangleSql x ^ " = NULL WHERE ")), loc), cond (x, v)), loc), L'.Error), loc), e), loc)) @@ -4584,8 +4584,8 @@ fun monoize env file = (L'.EStrcat ((L'.EPrim (Prim.String " OR "), loc), cond eb), loc)), loc)) - (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_" - ^ tab + (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM " + ^ Settings.mangleSql tab ^ " WHERE ")), loc), cond eb), loc) ebs, L'.Error), loc), @@ -4618,11 +4618,11 @@ fun monoize env file = (L'.ESeq ( (L'.EDml ((L'.EPrim (Prim.String (foldl (fn ((x, _), s) => - s ^ ", uw_" ^ x ^ " = NULL") + s ^ ", " ^ Settings.mangleSql x ^ " = NULL") ("UPDATE uw_" ^ tab - ^ " SET uw_" - ^ x + ^ " SET " + ^ Settings.mangleSql x ^ " = NULL") ebs)), loc), L'.Error), loc), e), loc) @@ -4632,8 +4632,8 @@ fun monoize env file = [] => e | eb :: ebs => (L'.ESeq ( - (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_" - ^ tab)), loc), L'.Error), loc), + (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM " + ^ Settings.mangleSql tab)), loc), L'.Error), loc), e), loc) in e diff --git a/src/mysql.sml b/src/mysql.sml index 884cde36..a119321c 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -76,7 +76,11 @@ val ident = String.translate (fn #"'" => "PRIME" fun checkRel (table, checkNullable) (s, xts) = let val sl = CharVector.map Char.toLower s - val both = "table_name IN ('" ^ sl ^ "', '" ^ s ^ "')" + val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then + String.substring (sl, 1, size sl - 2) + else + sl + val both = "LOWER(table_name) = ('" ^ sl ^ "')" val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE " ^ both @@ -85,14 +89,17 @@ fun checkRel (table, checkNullable) (s, xts) = " AND (", case String.concatWith " OR " (map (fn (x, t) => - String.concat ["(column_name IN ('uw_", - CharVector.map - Char.toLower (ident x), - "', 'uw_", - ident x, - "') AND data_type = '", - p_sql_type_base t, - "'", + String.concat ["(LOWER(column_name) = '", + Settings.mangleSqlCatalog + (CharVector.map + Char.toLower (ident x)), + "' AND data_type ", + case p_sql_type_base t of + "bigint" => + "IN ('bigint', 'int')" + | "longtext" => + "IN ('longtext', 'varchar')" + | s => "= '" ^ s ^ "'", if checkNullable then (" AND is_nullable = '" ^ (if isNotNull t then @@ -109,7 +116,7 @@ fun checkRel (table, checkNullable) (s, xts) = val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ", both, - " AND column_name LIKE 'uw_%'"] + " AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"] in box [string "if (mysql_query(conn->conn, \"", string q, @@ -174,7 +181,7 @@ fun checkRel (table, checkNullable) (s, xts) = string "mysql_close(conn->conn);", newline, string "uw_error(ctx, FATAL, \"Table '", - string s, + string sl, string "' does not exist.\");", newline], string "}", @@ -249,7 +256,7 @@ fun checkRel (table, checkNullable) (s, xts) = string "mysql_close(conn->conn);", newline, string "uw_error(ctx, FATAL, \"Table '", - string s, + string sl, string "' has the wrong column types.\");", newline], string "}", @@ -324,7 +331,7 @@ fun checkRel (table, checkNullable) (s, xts) = string "mysql_close(conn->conn);", newline, string "uw_error(ctx, FATAL, \"Table '", - string s, + string sl, string "' has extra columns.\");", newline], string "}", @@ -1201,15 +1208,21 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = box []] fun dmlCommon {loc, dml, mode} = - box [string "if (mysql_stmt_execute(stmt)) ", - case mode of - Settings.Error => box [string "uw_error(ctx, FATAL, \"", - string (ErrorMsg.spanToString loc), - string ": Error executing DML: %s\\n%s\", ", - dml, - string ", mysql_error(conn->conn));"] - | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));", - newline, + box [string "if (mysql_stmt_execute(stmt)) {", + box [string "if (mysql_errno(conn->conn) == 1213)", + newline, + box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");", + newline], + newline, + case mode of + Settings.Error => box [string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error executing DML: %s\\n%s\", ", + dml, + string ", mysql_error(conn->conn));"] + | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));", + newline], + string "}", newline] fun dml (loc, mode) = diff --git a/src/postgres.sml b/src/postgres.sml index 8cfa5f48..6ed7eeb0 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -63,8 +63,12 @@ fun p_sql_type_base t = fun checkRel (table, checkNullable) (s, xts) = let val sl = CharVector.map Char.toLower s + val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then + String.substring (sl, 1, size sl - 2) + else + sl - val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '" + val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE LOWER(table_name) = '" ^ sl ^ "'" val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '", @@ -72,12 +76,15 @@ fun checkRel (table, checkNullable) (s, xts) = "' AND (", case String.concatWith " OR " (map (fn (x, t) => - String.concat ["(column_name = 'uw_", - CharVector.map - Char.toLower (ident x), + String.concat ["(LOWER(column_name) = '", + Settings.mangleSqlCatalog + (CharVector.map + Char.toLower (ident x)), (case p_sql_type_base t of "bigint" => - "' AND data_type IN ('bigint', 'numeric')" + "' AND data_type IN ('bigint', 'numeric', 'integer')" + | "text" => + "' AND data_type IN ('text', 'character varying')" | t => String.concat ["' AND data_type = '", t, @@ -98,7 +105,7 @@ fun checkRel (table, checkNullable) (s, xts) = val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '", sl, - "' AND column_name LIKE 'uw_%'"] + "' AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"] in box [string "res = PQexec(conn, \"", string q, @@ -140,7 +147,7 @@ fun checkRel (table, checkNullable) (s, xts) = string "PQfinish(conn);", newline, string "uw_error(ctx, FATAL, \"Table '", - string s, + string sl, string "' does not exist.\");", newline], string "}", @@ -191,7 +198,7 @@ fun checkRel (table, checkNullable) (s, xts) = string "PQfinish(conn);", newline, string "uw_error(ctx, FATAL, \"Table '", - string s, + string sl, string "' has the wrong column types.\");", newline], string "}", @@ -243,7 +250,7 @@ fun checkRel (table, checkNullable) (s, xts) = string "PQfinish(conn);", newline, string "uw_error(ctx, FATAL, \"Table '", - string s, + string sl, string "' has extra columns.\");", newline], string "}", diff --git a/src/settings.sig b/src/settings.sig index 40cfbacc..847cb5f6 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -258,6 +258,11 @@ signature SETTINGS = sig val setTimeFormat : string -> unit val getTimeFormat : unit -> string - val getCCompiler : unit -> string - val setCCompiler : string -> unit + val getCCompiler : unit -> string + val setCCompiler : string -> unit + + val setMangleSql : bool -> unit + val mangleSql : string -> string + val mangleSqlCatalog : string -> string + val mangleSqlTable : string -> string end diff --git a/src/settings.sml b/src/settings.sml index eaaa374d..ebe38b17 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -696,4 +696,24 @@ val timeFormat = ref "%c" fun setTimeFormat v = timeFormat := v fun getTimeFormat () = !timeFormat +fun lowercase s = + case s of + "" => "" + | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun capitalize s = + case s of + "" => "" + | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +val mangle = ref true +fun setMangleSql x = mangle := x +fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s + else if #name (currentDbms ()) = "mysql" then capitalize s + else "\"" ^ lowercase s ^ "\"" +fun mangleSql s = if !mangle then "uw_" ^ s + else if #name (currentDbms ()) = "mysql" then lowercase s + else "\"" ^ lowercase s ^ "\"" +fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s + end |