diff options
| -rw-r--r-- | doc/manual.tex | 1 | ||||
| -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 |
7 files changed, 111 insertions, 64 deletions
diff --git a/doc/manual.tex b/doc/manual.tex index 9bc52f4c..6fe1a92c 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -170,6 +170,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{linker CMD} sets \texttt{CMD} as the command line prefix to use for linking C object files. The command line will be completed with a space-separated list of \texttt{.o} and \texttt{.a} files, \texttt{-L} and \texttt{-l} flags, and finally with a \texttt{-o} flag to set the location where the executable should be written. \item \texttt{minHeap NUMBYTES} sets the initial size for thread-local heaps used in handling requests. These heaps grow automatically as needed (up to any maximum set with \texttt{limit}), but each regrow requires restarting the request handling process. \item \texttt{monoInline TREESIZE} sets how many nodes the AST of a function definition may have before the optimizer stops trying hard to inline calls to that function. (This is one of two options for one of two intermediate languages within the compiler.) +\item \texttt{noMangleSql} avoids adding a \texttt{uw\_} prefix in front of each identifier in SQL. With this experimental feature, the burden is on the programmer to avoid naming tables or columns after SQL keywords! \item \texttt{noXsrfProtection URIPREFIX} turns off automatic cross-site request forgery protection for the page handler identified by the given URI prefix. This will avoid checking cryptographic signatures on cookies, which is generally a reasonable idea for some pages, such as login pages that are going to discard all old cookie values, anyway. \item \texttt{onError Module.var} changes the handling of fatal application errors. Instead of displaying a default, ugly error 500 page, the error page will be generated by calling function \texttt{Module.var} on a piece of XML representing the error message. The error handler should have type $\mt{xbody} \to \mt{transaction} \; \mt{page}$. Note that the error handler \emph{cannot} be in the application's main module, since that would register it as explicitly callable via URLs. \item \texttt{path NAME=VALUE} creates a mapping from \texttt{NAME} to \texttt{VALUE}. This mapping may be used at the beginnings of filesystem paths given to various other configuration directives. A path like \texttt{\$NAME/rest} is expanded to \texttt{VALUE/rest}. There is an initial mapping from the empty name (for paths like \texttt{\$/list}) to the directory where the Ur/Web standard library is installed. If you accept the default \texttt{configure} options, this directory is \texttt{/usr/local/lib/urweb/ur}. 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 |