adam@1391: (* Copyright (c) 2008-2011, Adam Chlipala adamc@29: * All rights reserved. adamc@29: * adamc@29: * Redistribution and use in source and binary forms, with or without adamc@29: * modification, are permitted provided that the following conditions are met: adamc@29: * adamc@29: * - Redistributions of source code must retain the above copyright notice, adamc@29: * this list of conditions and the following disclaimer. adamc@29: * - Redistributions in binary form must reproduce the above copyright notice, adamc@29: * this list of conditions and the following disclaimer in the documentation adamc@29: * and/or other materials provided with the distribution. adamc@29: * - The names of contributors may not be used to endorse or promote products adamc@29: * derived from this software without specific prior written permission. adamc@29: * adamc@29: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@29: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@29: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@29: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@29: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@29: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@29: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@29: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@29: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@29: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@29: * POSSIBILITY OF SUCH DAMAGE. adamc@29: *) adamc@29: adamc@29: (* Pretty-printing C jr. *) adamc@29: adamc@29: structure CjrPrint :> CJR_PRINT = struct adamc@29: adamc@29: open Print.PD adamc@29: open Print adamc@29: adamc@29: open Cjr adamc@29: adamc@269: val dummyt = (TRecord 0, ErrorMsg.dummySpan) adamc@269: adamc@29: structure E = CjrEnv adamc@29: structure EM = ErrorMsg adamc@29: adamc@144: structure SK = struct adamc@144: type ord_key = string adamc@144: val compare = String.compare adamc@144: end adamc@144: adamc@144: structure SS = BinarySetFn(SK) adamc@144: structure SM = BinaryMapFn(SK) adamc@144: structure IS = IntBinarySet adamc@144: adamc@144: structure CM = BinaryMapFn(struct adamc@144: type ord_key = char adamc@144: val compare = Char.compare adamc@144: end) adamc@144: adamc@29: val debug = ref false adamc@29: adamc@196: val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) adamc@29: adamc@316: val ident = String.translate (fn #"'" => "PRIME" adamc@316: | ch => str ch) adamc@316: adamc@316: val p_ident = string o ident adamc@316: adamc@463: fun isUnboxable (t : typ) = adamc@463: case #1 t of adamc@463: TDatatype (Default, _, _) => true adamc@463: | TFfi ("Basis", "string") => true adam@1370: | TFfi ("Basis", "queryString") => true adamc@463: | _ => false adamc@463: adamc@29: fun p_typ' par env (t, loc) = adamc@29: case t of adamc@476: TFun (t1, t2) => (EM.errorAt loc "Function type remains"; adamc@476: string "") adam@1431: | TRecord 0 => string "uw_unit" adamc@29: | TRecord i => box [string "struct", adamc@29: space, adamc@311: string "__uws_", adamc@29: string (Int.toString i)] adamc@188: | TDatatype (Enum, n, _) => adamc@188: (box [string "enum", adamc@188: space, adamc@1257: string ("__uwe_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n)] adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) adamc@198: | TDatatype (Option, n, xncs) => adamc@198: (case ListUtil.search #3 (!xncs) of adamc@198: NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument" adamc@198: | SOME t => adamc@897: if isUnboxable t then adamc@897: p_typ' par env t adamc@897: else adamc@897: box [p_typ' par env t, adamc@897: string "*"]) adamc@188: | TDatatype (Default, n, _) => adamc@165: (box [string "struct", adamc@165: space, adamc@1257: string ("__uwd_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n ^ "*")] adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) adamc@316: | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] adamc@288: | TOption t => adamc@463: if isUnboxable t then adamc@463: p_typ' par env t adamc@463: else adamc@463: box [p_typ' par env t, adamc@463: string "*"] adamc@757: | TList (_, i) => box [string "struct", adamc@757: space, adamc@757: string "__uws_", adamc@757: string (Int.toString i), adamc@757: string "*"] adamc@29: adamc@29: and p_typ env = p_typ' false env adamc@29: adamc@316: fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) adamc@311: handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) adamc@29: adam@1294: fun p_enamed' env n = adam@1294: "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n adam@1294: handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n adam@1294: adam@1294: fun p_enamed env n = string (p_enamed' env n) adamc@109: adamc@182: fun p_con_named env n = adamc@316: string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n) adamc@182: adamc@182: fun p_pat_preamble env (p, _) = adamc@182: case p of adamc@182: PWild => (box [], adamc@182: env) adamc@182: | PVar (x, t) => (box [p_typ env t, adamc@182: space, adamc@311: string "__uwr_", adamc@316: p_ident x, adamc@182: string "_", adamc@182: string (Int.toString (E.countERels env)), adamc@182: string ";", adamc@182: newline], adamc@196: E.pushERel env x t) adamc@182: | PPrim _ => (box [], env) adamc@188: | PCon (_, _, NONE) => (box [], env) adamc@188: | PCon (_, _, SOME p) => p_pat_preamble env p adamc@182: | PRecord xps => adamc@182: foldl (fn ((_, p, _), (pp, env)) => adamc@182: let adamc@182: val (pp', env) = p_pat_preamble env p adamc@182: in adamc@182: (box [pp', pp], env) adamc@182: end) (box [], env) xps adamc@288: | PNone _ => (box [], env) adamc@288: | PSome (_, p) => p_pat_preamble env p adamc@182: adamc@182: fun p_patCon env pc = adamc@182: case pc of adamc@182: PConVar n => p_con_named env n adamc@316: | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con) adamc@182: adam@1431: fun p_patMatch (env, disc) (p, loc) = adamc@182: case p of adam@1431: PWild => string "1" adam@1431: | PVar _ => string "1" adam@1431: | PPrim (Prim.Int n) => box [string ("(" ^ disc), adam@1431: space, adam@1431: string "==", adam@1431: space, adam@1431: Prim.p_t_GCC (Prim.Int n), adam@1431: string ")"] adam@1431: | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc), adam@1431: string ",", adam@1431: space, adam@1431: Prim.p_t_GCC (Prim.String s), adam@1431: string ")"] adam@1431: | PPrim (Prim.Char ch) => box [string ("(" ^ disc), adam@1431: space, adam@1431: string "==", adam@1431: space, adam@1431: Prim.p_t_GCC (Prim.Char ch), adam@1431: string ")"] adamc@182: | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" adamc@182: adamc@188: | PCon (dk, pc, po) => adamc@182: let adam@1431: val p = adamc@182: case po of adam@1431: NONE => box [] adamc@182: | SOME p => adamc@182: let adamc@182: val (x, to) = case pc of adamc@182: PConVar n => adamc@182: let adamc@182: val (x, to, _) = E.lookupConstructor env n adamc@182: in adamc@316: ("uw_" ^ ident x, to) adamc@182: end adamc@188: | PConFfi {mod = m, con, arg, ...} => adamc@316: ("uw_" ^ ident m ^ "_" ^ ident con, arg) adamc@182: adamc@182: val t = case to of adamc@182: NONE => raise Fail "CjrPrint: Constructor mismatch" adamc@182: | SOME t => t adam@1431: adam@1431: val x = case pc of adam@1431: PConVar n => adam@1431: let adam@1431: val (x, _, _) = E.lookupConstructor env n adam@1431: in adam@1431: "uw_" ^ ident x adam@1431: end adam@1431: | PConFfi {mod = m, con, ...} => adam@1431: "uw_" ^ ident m ^ "_" ^ ident con adam@1431: adam@1431: val disc' = case dk of adam@1431: Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" adam@1431: | Default => disc ^ "->data." ^ x adam@1431: | Option => adam@1431: if isUnboxable t then adam@1431: disc adam@1431: else adam@1431: "(*" ^ disc ^ ")" adam@1431: adam@1431: val p = p_patMatch (env, disc') p adamc@182: in adam@1431: box [space, adam@1431: string "&&", adam@1431: space, adam@1431: p] adamc@182: end adamc@182: in adam@1431: box [string disc, adam@1431: case (dk, po) of adam@1431: (Enum, _) => box [space, adam@1431: string "==", adam@1431: space, adam@1431: p_patCon env pc] adam@1431: | (Default, _) => box [string "->tag", adam@1431: space, adam@1431: string "==", adam@1431: space, adam@1431: p_patCon env pc] adam@1431: | (Option, NONE) => box [space, adam@1431: string "==", adam@1431: space, adam@1431: string "NULL"] adam@1431: | (Option, SOME _) => box [space, adam@1431: string "!=", adam@1431: space, adam@1431: string "NULL"], adam@1431: p] adam@1431: end adam@1431: adam@1440: | PRecord [] => string "1" adam@1431: | PRecord xps => adam@1431: p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps adam@1431: adam@1431: | PNone _ => adam@1431: box [string disc, adam@1431: space, adam@1431: string "==", adam@1431: space, adam@1431: string "NULL"] adam@1431: adam@1431: | PSome (t, p) => adam@1431: let adam@1431: val disc' = if isUnboxable t then adam@1431: disc adam@1431: else adam@1431: "(*" ^ disc ^ ")" adam@1431: adam@1431: val p = p_patMatch (env, disc') p adam@1431: in adam@1431: box [string disc, adam@1431: space, adam@1431: string "!=", adam@1431: space, adam@1431: string "NULL", adam@1431: space, adam@1431: string "&&", adam@1431: space, adam@1431: p] adam@1431: end adam@1431: adam@1431: fun p_patBind (env, disc) (p, loc) = adam@1431: case p of adam@1431: PWild => adam@1431: (box [], env) adam@1431: | PVar (x, t) => adam@1431: (box [p_typ env t, adam@1431: space, adam@1431: string "__uwr_", adam@1431: p_ident x, adam@1431: string "_", adam@1431: string (Int.toString (E.countERels env)), adam@1431: space, adam@1431: string "=", adam@1431: space, adam@1431: string disc, adam@1431: string ";", adam@1431: newline], adam@1431: E.pushERel env x t) adam@1431: | PPrim _ => (box [], env) adam@1431: adam@1431: | PCon (_, _, NONE) => (box [], env) adam@1431: adam@1431: | PCon (dk, pc, SOME p) => adam@1431: let adam@1431: val (x, to) = case pc of adam@1431: PConVar n => adam@1431: let adam@1431: val (x, to, _) = E.lookupConstructor env n adam@1431: in adam@1431: ("uw_" ^ ident x, to) adam@1431: end adam@1431: | PConFfi {mod = m, con, arg, ...} => adam@1431: ("uw_" ^ ident m ^ "_" ^ ident con, arg) adam@1431: adam@1431: val t = case to of adam@1431: NONE => raise Fail "CjrPrint: Constructor mismatch" adam@1431: | SOME t => t adam@1431: adam@1431: val disc' = case dk of adam@1431: Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" adam@1431: | Default => disc ^ "->data." ^ x adam@1431: | Option => adam@1431: if isUnboxable t then adam@1431: disc adam@1431: else adam@1431: "(*" ^ disc ^ ")" adam@1431: in adam@1431: p_patBind (env, disc') p adamc@182: end adamc@182: adamc@182: | PRecord xps => adamc@182: let adamc@182: val (xps, env) = adam@1431: ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p) adam@1431: env xps adamc@182: in adam@1431: (p_list_sep (box []) (fn x => x) xps, adamc@182: env) adamc@182: end adamc@182: adam@1431: | PNone _ => (box [], env) adamc@288: adamc@288: | PSome (t, p) => adamc@288: let adam@1431: val disc' = if isUnboxable t then adam@1431: disc adam@1431: else adam@1431: "(*" ^ disc ^ ")" adamc@288: in adam@1431: p_patBind (env, disc') p adamc@288: end adamc@288: adamc@185: fun patConInfo env pc = adamc@185: case pc of adamc@185: PConVar n => adamc@185: let adamc@185: val (x, _, dn) = E.lookupConstructor env n adamc@185: val (dx, _) = E.lookupDatatype env dn adamc@185: in adamc@316: ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn, adamc@316: "__uwc_" ^ ident x ^ "_" ^ Int.toString n, adamc@316: "uw_" ^ ident x) adamc@185: end adamc@186: | PConFfi {mod = m, datatyp, con, ...} => adamc@316: ("uw_" ^ ident m ^ "_" ^ ident datatyp, adamc@316: "uw_" ^ ident m ^ "_" ^ ident con, adamc@316: "uw_" ^ ident con) adamc@185: adamc@743: fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen = adamc@278: case t of adamc@311: TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"] adamc@311: | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"] adamc@324: | TFfi ("Basis", "string") => adamc@324: if wontLeakStrings then adamc@324: e adamc@324: else adamc@737: box [string "uw_strdup(ctx, ", e, string ")"] adamc@311: | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] adamc@438: | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] adamc@743: | TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ", adamc@743: e, adamc@743: string ", ", adamc@743: eLen, adamc@743: string ")"] adamc@678: | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] adamc@682: | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"] adamc@467: adamc@278: | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; adamc@278: Print.eprefaces' [("Type", p_typ env tAll)]; adamc@278: string "ERROR") adamc@278: adamc@467: fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = adamc@467: case t of adamc@467: TOption t => adamc@747: box [string "(PQgetisnull(res, i, ", adamc@467: string (Int.toString i), adamc@467: string ") ? NULL : ", adamc@467: case t of adamc@467: (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i adamc@467: | _ => box [string "({", adamc@467: newline, adamc@467: p_typ env t, adamc@467: space, adamc@467: string "*tmp = uw_malloc(ctx, sizeof(", adamc@467: p_typ env t, adamc@467: string "));", adamc@467: newline, adamc@467: string "*tmp = ", adamc@467: p_getcol wontLeakStrings env t i, adamc@467: string ";", adamc@467: newline, adamc@467: string "tmp;", adamc@467: newline, adamc@467: string "})"], adamc@467: string ")"] adamc@467: | _ => adamc@747: box [string "(PQgetisnull(res, i, ", adamc@747: string (Int.toString i), adamc@747: string ") ? ", adamc@747: box [string "({", adamc@747: p_typ env tAll, adamc@747: space, adamc@747: string "tmp;", adamc@747: newline, adamc@747: string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #", adamc@747: string (Int.toString i), adamc@747: string "\");", adamc@747: newline, adamc@747: string "tmp;", adamc@747: newline, adamc@747: string "})"], adamc@747: string " : ", adamc@747: p_unsql wontLeakStrings env tAll adamc@747: (box [string "PQgetvalue(res, i, ", adamc@747: string (Int.toString i), adamc@747: string ")"]) adamc@747: (box [string "PQgetlength(res, i, ", adamc@747: string (Int.toString i), adamc@747: string ")"]), adamc@747: string ")"] adamc@467: adamc@867: datatype sql_type = datatype Settings.sql_type adamc@867: val isBlob = Settings.isBlob adamc@737: adamc@739: fun isFile (t : typ) = adamc@737: case #1 t of adamc@739: TFfi ("Basis", "file") => true adamc@737: | _ => false adamc@737: adamc@1011: fun p_sql_type t = string (Settings.p_sql_ctype t) adamc@282: adamc@282: fun getPargs (e, _) = adamc@282: case e of adamc@282: EPrim (Prim.String _) => [] adamc@282: | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2 adamc@282: adamc@282: | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)] adamc@282: | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)] adamc@282: | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] adamc@282: | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] adamc@439: | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] adamc@737: | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)] adamc@678: | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)] adamc@682: | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)] adamc@468: adamc@678: | ECase (e, adamc@678: [((PNone _, _), adamc@678: (EPrim (Prim.String "NULL"), _)), adamc@678: ((PSome (_, (PVar _, _)), _), adamc@678: (EFfiApp (m, x, [(ERel 0, _)]), _))], adamc@678: _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e)) adamc@468: adamc@491: | ECase (e, adamc@491: [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), adamc@491: (EPrim (Prim.String "TRUE"), _)), adamc@491: ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), adamc@491: (EPrim (Prim.String "FALSE"), _))], adamc@491: _) => [(e, Bool)] adamc@282: adamc@282: | _ => raise Fail "CjrPrint: getPargs" adamc@282: adamc@1324: val notLeakies = SS.fromList ["int", "float", "char", "time", "bool", "unit", "client", "channel", adamc@1324: "xhtml", "page", "xbody", "css_class"] adamc@1324: val notLeakies' = SS.fromList ["blob"] adamc@1324: adamc@324: fun notLeaky env allowHeapAllocated = adamc@324: let adamc@638: fun nl ok (t, _) = adamc@324: case t of adamc@324: TFun _ => false adamc@324: | TRecord n => adamc@324: let adamc@324: val xts = E.lookupStruct env n adamc@324: in adamc@638: List.all (fn (_, t) => nl ok t) xts adamc@324: end adamc@638: | TDatatype (dk, n, ref cons) => adamc@638: IS.member (ok, n) adamc@638: orelse adamc@638: ((allowHeapAllocated orelse dk = Enum) adamc@638: andalso adamc@638: let adamc@638: val ok' = IS.add (ok, n) adamc@638: in adamc@638: List.all (fn (_, _, to) => case to of adamc@638: NONE => true adamc@638: | SOME t => nl ok' t) cons adamc@638: end) adamc@1324: | TFfi ("Basis", t) => SS.member (notLeakies, t) adamc@1324: orelse (allowHeapAllocated andalso SS.member (notLeakies', t)) adamc@1324: | TFfi _ => false adamc@638: | TOption t => allowHeapAllocated andalso nl ok t adamc@757: | TList (t, _) => allowHeapAllocated andalso nl ok t adamc@324: in adamc@638: nl IS.empty adamc@324: end adamc@324: adamc@463: fun capitalize s = adamc@463: if s = "" then adamc@463: "" adamc@463: else adamc@463: str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@463: adam@1516: local adam@1516: val urlHandlers = ref ([] : pp_desc list) adam@1516: in adam@1516: adam@1516: fun addUrlHandler v = urlHandlers := v :: !urlHandlers adam@1516: adam@1516: fun latestUrlHandlers () = adam@1516: !urlHandlers adam@1516: before urlHandlers := [] adam@1516: adam@1516: fun clearUrlHandlers () = urlHandlers := [] adam@1516: adam@1516: end adam@1516: adam@1516: val unurlifies = ref IS.empty adam@1516: adamc@1023: fun unurlify fromClient env (t, loc) = adamc@463: let adam@1516: fun unurlify' request t = adamc@463: case t of adam@1516: TFfi ("Basis", "unit") => string ("uw_Basis_unurlifyUnit(ctx, &" ^ request ^ ")") adamc@1023: | TFfi ("Basis", "string") => string (if fromClient then adam@1516: "uw_Basis_unurlifyString_fromClient(ctx, &" ^ request ^ ")" adamc@1023: else adam@1516: "uw_Basis_unurlifyString(ctx, &" ^ request ^ ")") adam@1516: | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &" ^ request ^ ")") adamc@463: adam@1516: | TRecord 0 => string ("uw_Basis_unurlifyUnit(ctx, &" ^ request ^ ")") adamc@463: | TRecord i => adamc@463: let adamc@463: val xts = E.lookupStruct env i adamc@463: in adamc@463: box [string "({", adamc@463: newline, adamc@463: box (map (fn (x, t) => adamc@463: box [p_typ env t, adamc@463: space, adamc@463: string "uwr_", adamc@463: string x, adamc@463: space, adamc@463: string "=", adamc@463: space, adam@1516: unurlify' request (#1 t), adamc@463: string ";", adamc@463: newline]) xts), adamc@463: string "struct", adamc@463: space, adamc@463: string "__uws_", adamc@463: string (Int.toString i), adamc@463: space, adamc@463: string "tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "{", adamc@463: space, adamc@463: p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", adamc@463: string x]) xts, adamc@463: space, adamc@463: string "};", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@463: end adamc@463: adamc@463: | TDatatype (Enum, i, _) => adamc@463: let adamc@463: val (x, xncs) = E.lookupDatatype env i adamc@463: adamc@463: fun doEm xncs = adamc@463: case xncs of adamc@463: [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " adamc@463: ^ x ^ "\"), (enum __uwe_" adamc@463: ^ x ^ "_" ^ Int.toString i ^ ")0)") adamc@463: | (x', n, to) :: rest => adam@1516: box [string ("((!strncmp(" ^ request ^ ", \""), adamc@463: string x', adamc@463: string "\", ", adamc@463: string (Int.toString (size x')), adam@1516: string (") && (" ^ request ^ "["), adamc@463: string (Int.toString (size x')), adam@1516: string ("] == 0 || " ^ request ^ "["), adamc@463: string (Int.toString (size x')), adam@1516: string ("] == '/')) ? (" ^ request ^ " += "), adam@1360: string (Int.toString (size x')), adam@1516: string (", (" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"), adamc@463: space, adamc@463: string ":", adamc@463: space, adamc@463: doEm rest, adamc@463: string ")"] adamc@463: in adamc@463: doEm xncs adamc@463: end adamc@463: adamc@463: | TDatatype (Option, i, xncs) => adam@1516: if IS.member (!unurlifies, i) then adamc@463: box [string "unurlify_", adamc@463: string (Int.toString i), adam@1516: string ("(ctx, &" ^ request ^ ")")] adamc@463: else adamc@463: let adamc@463: val (x, _) = E.lookupDatatype env i adamc@463: adamc@463: val (no_arg, has_arg, t) = adamc@463: case !xncs of adamc@463: [(no_arg, _, NONE), (has_arg, _, SOME t)] => adamc@463: (no_arg, has_arg, t) adamc@463: | [(has_arg, _, SOME t), (no_arg, _, NONE)] => adamc@463: (no_arg, has_arg, t) adamc@463: | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" adam@1516: in adam@1516: unurlifies := IS.add (!unurlifies, i); adam@1516: addUrlHandler (box [string "static", adam@1516: space, adam@1516: p_typ env t, adam@1516: space, adam@1516: string "*unurlify_", adam@1516: string (Int.toString i), adam@1516: string "(uw_context ctx, char **request) {", adam@1516: newline, adam@1516: box [string "return ((*request)[0] == '/' ? ++*request : *request,", adam@1516: newline, adam@1516: string "((!strncmp(*request, \"", adam@1516: string no_arg, adam@1516: string "\", ", adam@1516: string (Int.toString (size no_arg)), adam@1516: string ") && ((*request)[", adam@1516: string (Int.toString (size no_arg)), adam@1516: string "] == 0 || (*request)[", adam@1516: string (Int.toString (size no_arg)), adam@1516: string "] == '/')) ? (*request", adam@1516: space, adam@1516: string "+=", adam@1516: space, adam@1516: string (Int.toString (size no_arg)), adam@1516: string ", NULL) : ((!strncmp(*request, \"", adam@1516: string has_arg, adam@1516: string "\", ", adam@1516: string (Int.toString (size has_arg)), adam@1516: string ") && ((*request)[", adam@1516: string (Int.toString (size has_arg)), adam@1516: string "] == 0 || (*request)[", adam@1516: string (Int.toString (size has_arg)), adam@1516: string "] == '/')) ? (*request", adam@1516: space, adam@1516: string "+=", adam@1516: space, adam@1516: string (Int.toString (size has_arg)), adam@1516: string ", ((*request)[0] == '/' ? ++*request : NULL), ", adam@1516: newline, adam@1516: adam@1516: if isUnboxable t then adam@1516: unurlify' "(*request)" (#1 t) adam@1516: else adam@1516: box [string "({", adam@1516: newline, adam@1516: p_typ env t, adam@1516: space, adam@1516: string "*tmp", adam@1516: space, adam@1516: string "=", adam@1516: space, adam@1516: string "uw_malloc(ctx, sizeof(", adam@1516: p_typ env t, adam@1516: string "));", adam@1516: newline, adam@1516: string "*tmp", adam@1516: space, adam@1516: string "=", adam@1516: space, adam@1516: unurlify' "(*request)" (#1 t), adam@1516: string ";", adam@1516: newline, adam@1516: string "tmp;", adam@1516: newline, adam@1516: string "})"], adam@1516: string ")", adam@1516: newline, adam@1516: string ":", adam@1516: space, adam@1516: string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x adam@1516: ^ "\"), NULL))));"), adam@1516: newline], adam@1516: string "}", adam@1516: newline, adam@1516: newline]); adamc@463: adam@1516: box [string "unurlify_", adam@1516: string (Int.toString i), adam@1516: string ("(ctx, &" ^ request ^ ")")] adamc@463: end adamc@463: adamc@463: | TDatatype (Default, i, _) => adam@1516: if IS.member (!unurlifies, i) then adamc@463: box [string "unurlify_", adamc@463: string (Int.toString i), adam@1516: string ("(ctx, &" ^ request ^ ")")] adamc@463: else adamc@463: let adamc@463: val (x, xncs) = E.lookupDatatype env i adamc@463: adam@1516: val () = unurlifies := IS.add (!unurlifies, i) adamc@463: adamc@463: fun doEm xncs = adamc@463: case xncs of adamc@463: [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " adamc@463: ^ x ^ "\"), NULL)") adamc@463: | (x', n, to) :: rest => adam@1516: box [string "((!strncmp(*request, \"", adamc@463: string x', adamc@463: string "\", ", adamc@463: string (Int.toString (size x')), adam@1516: string ") && ((*request)[", adamc@463: string (Int.toString (size x')), adam@1516: string "] == 0 || (*request)[", adamc@463: string (Int.toString (size x')), adamc@463: string "] == '/')) ? ({", adamc@463: newline, adamc@463: string "struct", adamc@463: space, adamc@463: string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), adamc@463: space, adamc@463: string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", adamc@463: string x, adamc@463: string "_", adamc@463: string (Int.toString i), adamc@463: string "));", adamc@463: newline, adamc@463: string "tmp->tag", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), adamc@463: string ";", adamc@463: newline, adam@1516: string "*request", adamc@463: space, adamc@463: string "+=", adamc@463: space, adamc@463: string (Int.toString (size x')), adamc@463: string ";", adamc@463: newline, adam@1516: string "if ((*request)[0] == '/') ++*request;", adamc@463: newline, adamc@463: case to of adamc@463: NONE => box [] adamc@463: | SOME (t, _) => box [string "tmp->data.uw_", adamc@463: p_ident x', adamc@463: space, adamc@463: string "=", adamc@463: space, adam@1516: unurlify' "(*request)" t, adamc@463: string ";", adamc@463: newline], adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})", adamc@463: space, adamc@463: string ":", adamc@463: space, adamc@463: doEm rest, adamc@463: string ")"] adamc@463: in adam@1516: addUrlHandler (box [string "static", adam@1516: space, adam@1516: p_typ env (t, ErrorMsg.dummySpan), adam@1516: space, adam@1516: string "unurlify_", adam@1516: string (Int.toString i), adam@1516: string "(uw_context ctx, char **request) {", adam@1516: newline, adam@1516: box [string "return", adam@1516: space, adam@1516: doEm xncs, adam@1516: string ";", adam@1516: newline], adam@1516: string "}", adam@1516: newline, adam@1516: newline]); adam@1516: adam@1516: box [string "unurlify_", adamc@463: string (Int.toString i), adam@1516: string ("(ctx, &" ^ request ^ ")")] adamc@463: end adamc@463: adamc@758: | TList (t', i) => adam@1516: if IS.member (!unurlifies, i) then adamc@758: box [string "unurlify_list_", adamc@758: string (Int.toString i), adam@1516: string ("(ctx, &" ^ request ^ ")")] adamc@758: else adam@1516: (unurlifies := IS.add (!unurlifies, i); adam@1516: addUrlHandler (box [string "static", adam@1516: space, adam@1516: p_typ env (t, loc), adam@1516: space, adam@1516: string "unurlify_list_", adam@1516: string (Int.toString i), adam@1516: string "(uw_context ctx, char **request) {", adam@1516: newline, adam@1516: box [string "return ((*request)[0] == '/' ? ++*request : *request,", adam@1516: newline, adam@1516: string "((!strncmp(*request, \"Nil\", 3) && ((*request)[3] == 0 ", adam@1516: string "|| (*request)[3] == '/')) ? (*request", adam@1516: space, adam@1516: string "+=", adam@1516: space, adam@1516: string "3, (*request == '/' ? *request++ = 0 : 0), NULL) : ((!strncmp(*request, \"Cons\", 4) && ((*request)[4] == 0 ", adam@1516: string "|| (*request)[4] == '/')) ? (*request", adam@1516: space, adam@1516: string "+=", adam@1516: space, adam@1516: string "4, ((*request)[0] == '/' ? ++*request : NULL), ", adam@1516: newline, adam@1516: adam@1516: string "({", adam@1516: newline, adam@1516: p_typ env (t, loc), adam@1516: space, adam@1516: string "tmp", adam@1516: space, adam@1516: string "=", adam@1516: space, adam@1516: string "uw_malloc(ctx, sizeof(struct __uws_", adam@1516: string (Int.toString i), adam@1516: string "));", adam@1516: newline, adam@1516: string "*tmp", adam@1516: space, adam@1516: string "=", adam@1516: space, adam@1516: unurlify' "(*request)" (TRecord i), adam@1516: string ";", adam@1516: newline, adam@1516: string "tmp;", adam@1516: newline, adam@1516: string "})", adam@1516: string ")", adam@1516: newline, adam@1516: string ":", adam@1516: space, adam@1516: string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"), adam@1516: newline], adam@1516: string "}", adam@1516: newline, adam@1516: newline]); adamc@758: adam@1516: box [string "unurlify_list_", adam@1516: string (Int.toString i), adam@1516: string ("(ctx, &" ^ request ^ ")")]) adamc@758: adamc@471: | TOption t => adam@1516: box [string ("(" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : " ^ request ^ ", "), adam@1516: string ("((!strncmp(" ^ request ^ ", \"None\", 4) "), adam@1516: string ("&& (" ^ request ^ "[4] == 0 || " ^ request ^ "[4] == '/')) "), adam@1516: string ("? (" ^ request ^ " += (" ^ request ^ "[4] == 0 ? 4 : 5), NULL) "), adam@1516: string (": ((!strncmp(" ^ request ^ ", \"Some\", 4) "), adam@1516: string ("&& " ^ request ^ "[4] == '/') "), adam@1516: string ("? (" ^ request ^ " += 5, "), adamc@471: if isUnboxable t then adam@1516: unurlify' request (#1 t) adamc@471: else adamc@471: box [string "({", adamc@471: newline, adamc@471: p_typ env t, adamc@471: space, adamc@471: string "*tmp", adamc@471: space, adamc@471: string "=", adamc@471: space, adamc@471: string "uw_malloc(ctx, sizeof(", adamc@471: p_typ env t, adamc@471: string "));", adamc@471: newline, adamc@471: string "*tmp", adamc@471: space, adamc@471: string "=", adamc@471: space, adam@1516: unurlify' request (#1 t), adamc@471: string ";", adamc@471: newline, adamc@471: string "tmp;", adamc@471: newline, adamc@471: string "})"], adamc@471: string ") :", adamc@471: space, adamc@471: string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"] adamc@471: adamc@463: | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; adamc@463: space) adamc@463: in adam@1516: unurlify' "request" t adamc@463: end adamc@463: adamc@905: val urlify1 = ref 0 adamc@905: adam@1516: val urlifies = ref IS.empty adam@1516: val urlifiesL = ref IS.empty adam@1516: adamc@610: fun urlify env t = adamc@610: let adam@1516: fun urlify' level (t as (_, loc)) = adamc@610: case #1 t of adamc@610: TFfi ("Basis", "unit") => box [] adamc@610: | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t adamc@610: ^ "_w(ctx, it" ^ Int.toString level ^ ");"), adamc@610: newline] adamc@610: adamc@610: | TRecord 0 => box [] adamc@610: | TRecord i => adamc@610: let adamc@611: fun empty (t, _) = adamc@611: case t of adamc@611: TFfi ("Basis", "unit") => true adamc@611: | TRecord 0 => true adamc@611: | TRecord j => adamc@611: List.all (fn (_, t) => empty t) (E.lookupStruct env j) adamc@611: | _ => false adamc@611: adamc@610: val xts = E.lookupStruct env i adamc@611: adamc@613: val (blocks, _) = foldl adamc@613: (fn ((x, t), (blocks, printingSinceLastSlash)) => adamc@613: let adamc@613: val thisEmpty = empty t adamc@613: in adamc@613: if thisEmpty then adamc@613: (blocks, printingSinceLastSlash) adamc@613: else adamc@613: (box [string "{", adamc@613: newline, adamc@613: p_typ env t, adamc@613: space, adamc@613: string ("it" ^ Int.toString (level + 1)), adamc@613: space, adamc@613: string "=", adamc@613: space, adamc@613: string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), adamc@613: newline, adamc@613: box (if printingSinceLastSlash then adamc@613: [string "uw_write(ctx, \"/\");", adamc@613: newline] adamc@613: else adamc@613: []), adam@1516: urlify' (level + 1) t, adamc@613: string "}", adamc@613: newline] :: blocks, adamc@613: true) adamc@613: end) adamc@613: ([], false) xts adamc@610: in adamc@613: box (rev blocks) adamc@610: end adamc@610: adamc@638: | TDatatype (Enum, i, _) => adamc@638: let adamc@610: val (x, xncs) = E.lookupDatatype env i adamc@610: adamc@610: fun doEm xncs = adamc@610: case xncs of adamc@638: [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " adamc@638: ^ x ^ "\");"), adamc@638: newline] adamc@610: | (x', n, to) :: rest => adamc@638: box [string ("if (it" ^ Int.toString level adamc@638: ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"), adamc@638: newline, adamc@638: box [string ("uw_write(ctx, \"" ^ x' ^ "\");"), adamc@638: newline], adamc@638: string "} else {", adamc@638: newline, adamc@638: box [doEm rest, adamc@638: newline], adamc@638: string "}"] adamc@610: in adamc@610: doEm xncs adamc@638: end adamc@610: adamc@639: | TDatatype (Option, i, xncs) => adam@1516: if IS.member (!urlifies, i) then adamc@639: box [string "urlify_", adamc@610: string (Int.toString i), adam@1516: string "(ctx,", adam@1516: space, adam@1516: string "it", adamc@639: string (Int.toString level), adamc@639: string ");", adamc@639: newline] adamc@610: else adamc@610: let adamc@610: val (x, _) = E.lookupDatatype env i adamc@610: adamc@610: val (no_arg, has_arg, t) = adamc@610: case !xncs of adamc@610: [(no_arg, _, NONE), (has_arg, _, SOME t)] => adamc@610: (no_arg, has_arg, t) adamc@610: | [(has_arg, _, SOME t), (no_arg, _, NONE)] => adamc@610: (no_arg, has_arg, t) adamc@639: | _ => raise Fail "CjrPrint: urlify misclassified Option datatype" adam@1516: in adam@1516: urlifies := IS.add (!urlifies, i); adam@1516: addUrlHandler (box [string "static", adam@1516: space, adam@1516: string "void", adam@1516: space, adam@1516: string "urlify_", adam@1516: string (Int.toString i), adam@1516: string "(uw_context ctx,", adam@1516: space, adam@1516: p_typ env t, adam@1516: space, adam@1516: if isUnboxable t then adam@1516: box [] adam@1516: else adam@1516: string "*", adam@1516: string "it0) {", adam@1516: newline, adam@1516: box [string "if (it0) {", adam@1516: newline, adam@1516: if isUnboxable t then adam@1516: urlify' 0 t adam@1516: else adam@1516: box [p_typ env t, adam@1516: space, adam@1516: string "it1", adam@1516: space, adam@1516: string "=", adam@1516: space, adam@1516: string "*it0;", adam@1516: newline, adam@1516: string "uw_write(ctx, \"", adam@1516: string has_arg, adam@1516: string "/\");", adam@1516: newline, adam@1516: urlify' 1 t, adam@1516: string ";", adam@1516: newline], adam@1516: string "} else {", adam@1516: box [newline, adam@1516: string "uw_write(ctx, \"", adam@1516: string no_arg, adam@1516: string "\");", adam@1516: newline], adam@1516: string "}", adam@1516: newline], adam@1516: string "}", adam@1516: newline, adam@1516: newline]); adamc@610: adam@1516: box [string "urlify_", adam@1516: string (Int.toString i), adam@1516: string "(ctx,", adamc@610: space, adam@1516: string "it", adamc@639: string (Int.toString level), adamc@639: string ");", adamc@639: newline] adamc@639: end adamc@610: adamc@640: | TDatatype (Default, i, _) => adam@1516: if IS.member (!urlifies, i) then adamc@640: box [string "urlify_", adamc@610: string (Int.toString i), adam@1516: string "(ctx,", adam@1516: space, adam@1516: string "it", adamc@640: string (Int.toString level), adamc@640: string ");", adamc@640: newline] adamc@610: else adamc@610: let adamc@610: val (x, xncs) = E.lookupDatatype env i adamc@610: adam@1516: val () = urlifies := IS.add (!urlifies, i) adamc@610: adamc@610: fun doEm xncs = adamc@610: case xncs of adamc@640: [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " adamc@640: ^ x ^ " (%d)\", it0->data);"), adamc@640: newline] adamc@610: | (x', n, to) :: rest => adamc@640: box [string "if", adamc@610: space, adamc@640: string "(it0->tag==__uwc_", adamc@640: string (ident x'), adamc@610: string "_", adamc@640: string (Int.toString n), adamc@640: string ") {", adamc@610: newline, adamc@610: case to of adamc@640: NONE => box [string "uw_write(ctx, \"", adamc@640: string x', adamc@640: string "\");", adamc@640: newline] adamc@640: | SOME t => box [string "uw_write(ctx, \"", adamc@640: string x', adamc@640: string "/\");", adamc@640: newline, adamc@640: p_typ env t, adamc@640: space, adamc@640: string "it1", adamc@640: space, adamc@640: string "=", adamc@640: space, adamc@640: string "it0->data.uw_", adamc@640: string x', adamc@640: string ";", adamc@640: newline, adam@1516: urlify' 1 t, adamc@640: newline], adamc@640: string "} else {", adamc@610: newline, adamc@640: box [doEm rest, adamc@640: newline], adamc@640: string "}", adamc@640: newline] adamc@610: in adam@1516: addUrlHandler (box [string "static", adam@1516: space, adam@1516: string "void", adam@1516: space, adam@1516: string "urlify_", adam@1516: string (Int.toString i), adam@1516: string "(uw_context ctx,", adam@1516: space, adam@1516: p_typ env t, adam@1516: space, adam@1516: string "it0) {", adam@1516: newline, adam@1516: box [doEm xncs, adam@1516: newline], adam@1516: newline, adam@1516: string "}", adam@1516: newline, adam@1516: newline]); adam@1516: adam@1516: box [string "urlify_", adam@1516: string (Int.toString i), adam@1516: string "(ctx,", adamc@610: space, adam@1516: string "it", adamc@640: string (Int.toString level), adamc@640: string ");", adamc@640: newline] adamc@640: end adamc@610: adamc@641: | TOption t => adamc@641: box [string "if (it", adamc@641: string (Int.toString level), adamc@641: string ") {", adamc@641: if isUnboxable t then adamc@641: box [string "uw_write(ctx, \"Some/\");", adamc@641: newline, adam@1516: urlify' level t] adamc@610: else adamc@641: box [p_typ env t, adamc@610: space, adamc@641: string "it", adamc@641: string (Int.toString (level + 1)), adamc@610: space, adamc@610: string "=", adamc@610: space, adamc@641: string "*it", adamc@641: string (Int.toString level), adamc@610: string ";", adamc@610: newline, adamc@641: string "uw_write(ctx, \"Some/\");", adamc@610: newline, adam@1516: urlify' (level + 1) t, adamc@641: string ";", adamc@641: newline], adamc@641: string "} else {", adamc@905: box [newline, adamc@905: string "uw_write(ctx, \"None\");", adamc@641: newline], adamc@641: string "}", adamc@641: newline] adamc@610: adamc@905: | TList (t, i) => adam@1516: if IS.member (!urlifiesL, i) then adamc@905: box [string "urlifyl_", adamc@905: string (Int.toString i), adam@1516: string "(ctx,", adam@1516: space, adam@1516: string "it", adamc@905: string (Int.toString level), adamc@905: string ");", adamc@905: newline] adamc@905: else adam@1516: (urlifiesL := IS.add (!urlifiesL, i); adam@1516: addUrlHandler (box [string "static", adam@1516: space, adam@1516: string "void", adam@1516: space, adam@1516: string "urlifyl_", adam@1516: string (Int.toString i), adam@1516: string "(uw_context ctx,", adam@1516: space, adam@1516: string "struct __uws_", adam@1516: string (Int.toString i), adam@1516: space, adam@1516: string "*it0) {", adam@1516: newline, adam@1516: box [string "if (it0) {", adam@1516: newline, adam@1516: p_typ env t, adam@1516: space, adam@1516: string "it1", adam@1516: space, adam@1516: string "=", adam@1516: space, adam@1516: string "it0->__uwf_1;", adam@1516: newline, adam@1516: string "uw_write(ctx, \"Cons/\");", adam@1516: newline, adam@1516: urlify' 1 t, adam@1516: string ";", adam@1516: newline, adam@1516: string "uw_write(ctx, \"/\");", adam@1516: newline, adam@1516: string "urlifyl_", adam@1516: string (Int.toString i), adam@1516: string "(ctx, it0->__uwf_2);", adam@1516: newline, adam@1516: string "} else {", adam@1516: newline, adam@1516: box [string "uw_write(ctx, \"Nil\");", adam@1516: newline], adam@1516: string "}", adam@1516: newline], adam@1516: string "}", adam@1516: newline, adam@1516: newline]); adamc@905: adam@1516: box [string "urlifyl_", adam@1516: string (Int.toString i), adam@1516: string "(ctx,", adam@1516: space, adam@1516: string "it", adam@1516: string (Int.toString level), adam@1516: string ");", adam@1516: newline]) adam@1516: adamc@610: | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; adamc@610: space) adamc@610: in adam@1516: urlify' 0 t adamc@610: end adamc@610: adamc@867: fun sql_type_in env (tAll as (t, loc)) = adamc@867: case t of adamc@867: TFfi ("Basis", "int") => Int adamc@867: | TFfi ("Basis", "float") => Float adamc@867: | TFfi ("Basis", "string") => String adamc@1011: | TFfi ("Basis", "char") => Char adamc@867: | TFfi ("Basis", "bool") => Bool adamc@867: | TFfi ("Basis", "time") => Time adamc@867: | TFfi ("Basis", "blob") => Blob adamc@867: | TFfi ("Basis", "channel") => Channel adamc@867: | TFfi ("Basis", "client") => Client adamc@867: | TOption t' => Nullable (sql_type_in env t') adamc@867: | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; adamc@867: Print.eprefaces' [("Type", p_typ env tAll)]; adamc@867: Int) adamc@867: adam@1391: fun potentiallyFancy (e, _) = adam@1391: case e of adam@1391: EPrim _ => false adam@1391: | ERel _ => false adam@1391: | ENamed _ => false adam@1391: | ECon (_, _, NONE) => false adam@1391: | ECon (_, _, SOME e) => potentiallyFancy e adam@1391: | ENone _ => false adam@1391: | ESome (_, e) => potentiallyFancy e adam@1391: | EFfi _ => false adam@1391: | EFfiApp _ => true adam@1391: | EApp _ => true adam@1391: | EUnop (_, e) => potentiallyFancy e adam@1391: | EBinop (_, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2 adam@1391: | ERecord (_, xes) => List.exists (potentiallyFancy o #2) xes adam@1391: | EField (e, _) => potentiallyFancy e adam@1391: | ECase (e, pes, _) => potentiallyFancy e orelse List.exists (potentiallyFancy o #2) pes adam@1391: | EError _ => false adam@1391: | EReturnBlob _ => false adam@1391: | ERedirect _ => false adam@1391: | EWrite e => potentiallyFancy e adam@1391: | ESeq (e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2 adam@1391: | ELet (_, _, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2 adam@1391: | EQuery _ => true adam@1391: | EDml {dml = e, ...} => potentiallyFancy e adam@1391: | ENextval {seq = e, ...} => potentiallyFancy e adam@1391: | ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2 adam@1391: | EUnurlify _ => true adam@1391: adam@1524: val self = ref (NONE : int option) adam@1524: adam@1524: fun p_exp' par tail env (e, loc) = adamc@29: case e of adamc@276: EPrim p => Prim.p_t_GCC p adamc@29: | ERel n => p_rel env n adamc@109: | ENamed n => p_enamed env n adamc@188: | ECon (Enum, pc, _) => p_patCon env pc adamc@198: | ECon (Option, pc, NONE) => string "NULL" adamc@198: | ECon (Option, pc, SOME e) => adamc@198: let adamc@198: val to = case pc of adamc@198: PConVar n => #2 (E.lookupConstructor env n) adamc@198: | PConFfi {arg, ...} => arg adamc@198: adamc@198: val t = case to of adamc@198: NONE => raise Fail "CjrPrint: ECon argument status mismatch" adamc@198: | SOME t => t adamc@198: in adamc@463: if isUnboxable t then adam@1524: p_exp' par tail env e adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: space, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adam@1516: space, adam@1524: p_exp' par false env e, adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@198: end adamc@188: | ECon (Default, pc, eo) => adamc@181: let adamc@196: val (xd, xc, xn) = patConInfo env pc adamc@181: in adamc@182: box [string "({", adamc@181: newline, adamc@181: string "struct", adamc@181: space, adamc@185: string xd, adamc@181: space, adamc@181: string "*tmp", adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@311: string "uw_malloc(ctx, sizeof(struct ", adamc@185: string xd, adamc@181: string "));", adamc@181: newline, adamc@181: string "tmp->tag", adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@185: string xc, adamc@181: string ";", adamc@181: newline, adamc@181: case eo of adamc@181: NONE => box [] adamc@185: | SOME e => box [string "tmp->data.", adamc@196: string xn, adamc@181: space, adamc@181: string "=", adamc@181: space, adam@1524: p_exp' false false env e, adamc@181: string ";", adamc@181: newline], adamc@181: string "tmp;", adamc@181: newline, adamc@181: string "})"] adamc@181: end adamc@297: | ENone _ => string "NULL" adamc@290: | ESome (t, e) => adamc@463: if isUnboxable t then adam@1524: p_exp' par tail env e adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: space, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adam@1516: space, adam@1524: p_exp' par false env e, adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@109: adamc@316: | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] adamc@283: | EError (e, t) => adamc@283: box [string "({", adamc@283: newline, adamc@283: p_typ env t, adamc@283: space, adamc@283: string "tmp;", adamc@283: newline, adamc@311: string "uw_error(ctx, FATAL, \"", adamc@292: string (ErrorMsg.spanToString loc), adamc@292: string ": %s\", ", adam@1524: p_exp' false false env e, adamc@283: string ");", adamc@283: newline, adamc@283: string "tmp;", adamc@283: newline, adamc@283: string "})"] adamc@741: | EReturnBlob {blob, mimeType, t} => adamc@741: box [string "({", adamc@741: newline, adamc@741: p_typ env t, adamc@741: space, adamc@741: string "tmp;", adamc@741: newline, adamc@741: string "uw_return_blob(ctx, ", adam@1524: p_exp' false false env blob, adamc@741: string ", ", adam@1524: p_exp' false false env mimeType, adamc@741: string ");", adamc@741: newline, adamc@741: string "tmp;", adamc@741: newline, adamc@741: string "})"] adamc@1065: | ERedirect (e, t) => adamc@1065: box [string "({", adamc@1065: newline, adamc@1065: p_typ env t, adamc@1065: space, adamc@1065: string "tmp;", adamc@1065: newline, adamc@1065: string "uw_redirect(ctx, ", adam@1524: p_exp' false false env e, adamc@1065: string ");", adamc@1065: newline, adamc@1065: string "tmp;", adamc@1065: newline, adamc@1065: string "})"] adamc@476: | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => adam@1524: p_exp' false false env (EError (e, ran), loc) adamc@741: | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) => adam@1524: p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc) adamc@476: adamc@922: | EFfiApp ("Basis", "strcat", [e1, e2]) => adamc@922: let adamc@922: fun flatten e = adamc@922: case #1 e of adamc@922: EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2 adamc@922: | _ => [e] adamc@922: in adamc@922: case flatten e1 @ flatten e2 of adamc@922: [e1, e2] => box [string "uw_Basis_strcat(ctx, ", adam@1524: p_exp' false false env e1, adamc@922: string ",", adam@1524: p_exp' false false env e2, adamc@922: string ")"] adamc@922: | es => box [string "uw_Basis_mstrcat(ctx, ", adam@1524: p_list (p_exp' false false env) es, adamc@922: string ", NULL)"] adamc@922: end adamc@922: adamc@765: | EFfiApp (m, x, []) => box [string "uw_", adamc@765: p_ident m, adamc@765: string "_", adamc@765: p_ident x, adamc@765: string "(ctx)"] adamc@765: adamc@311: | EFfiApp (m, x, es) => box [string "uw_", adamc@316: p_ident m, adamc@53: string "_", adamc@316: p_ident x, adamc@117: string "(ctx, ", adam@1524: p_list (p_exp' false false env) es, adamc@53: string ")"] adamc@316: | EApp (f, args) => adam@1524: let adam@1524: fun default () = parenIf par (box [p_exp' true false env f, adam@1524: string "(ctx,", adam@1524: space, adam@1524: p_list_sep (box [string ",", space]) (p_exp' false false env) args, adam@1524: string ")"]) adam@1524: adam@1524: fun isSelf n = adam@1524: let adam@1524: val (_, t) = E.lookupENamed env n adam@1524: adam@1524: fun getSig (t, args) = adam@1524: case #1 t of adam@1524: TFun (dom, t) => getSig (t, dom :: args) adam@1524: | _ => (args, t) adam@1524: adam@1524: val (argts, ret) = getSig (t, []) adam@1524: in adam@1524: parenIf par (box [string "({", adam@1524: newline, adam@1524: p_list_sepi newline adam@1524: (fn i => fn (e, t) => adam@1524: box [p_typ env t, adam@1524: space, adam@1524: string ("rearg" ^ Int.toString i), adam@1524: space, adam@1524: string "=", adam@1524: space, adam@1524: p_exp' false false env e, adam@1524: string ";"]) adam@1524: (ListPair.zip (args, argts)), adam@1524: newline, adam@1524: p_typ env ret, adam@1524: space, adam@1524: string "tmp;", adam@1524: newline, adam@1524: p_list_sepi newline adam@1524: (fn i => fn _ => adam@1524: box [p_rel env (E.countERels env - 1 - i), adam@1524: space, adam@1524: string "=", adam@1524: space, adam@1524: string ("rearg" ^ Int.toString i ^ ";")]) args, adam@1524: newline, adam@1524: string "goto restart;", adam@1524: newline, adam@1524: string "tmp;", adam@1524: newline, adam@1524: string "})"]) adam@1524: end adam@1524: in adam@1524: case #1 f of adam@1524: ENamed n => if SOME n = !self andalso tail then adam@1524: isSelf n adam@1524: else adam@1524: default () adam@1524: | _ => default () adam@1524: end adamc@29: adamc@387: | EUnop (s, e1) => adamc@387: parenIf par (box [string s, adamc@387: space, adam@1524: p_exp' true false env e1]) adamc@387: adamc@387: | EBinop (s, e1, e2) => adamc@389: if Char.isAlpha (String.sub (s, size s - 1)) then adamc@389: box [string s, adamc@390: string "(", adam@1524: p_exp' false false env e1, adamc@389: string ",", adamc@389: space, adam@1524: p_exp' false false env e2, adamc@389: string ")"] adamc@389: else adam@1524: parenIf par (box [p_exp' true false env e1, adamc@389: space, adamc@389: string s, adamc@389: space, adam@1524: p_exp' true false env e2]) adamc@387: adam@1431: | ERecord (0, _) => string "0" adam@1431: adamc@29: | ERecord (i, xes) => box [string "({", adamc@29: space, adamc@29: string "struct", adamc@29: space, adamc@311: string ("__uws_" ^ Int.toString i), adamc@29: space, adamc@181: string "tmp", adamc@29: space, adamc@29: string "=", adamc@29: space, adamc@29: string "{", adamc@29: p_list (fn (_, e) => adam@1524: p_exp' false false env e) xes, adamc@29: string "};", adamc@29: space, adamc@181: string "tmp;", adamc@29: space, adamc@29: string "})" ] adamc@29: | EField (e, x) => adam@1524: box [p_exp' true false env e, adamc@311: string ".__uwf_", adamc@316: p_ident x] adamc@29: adamc@182: | ECase (e, pes, {disc, result}) => adam@1431: box [string "({", adam@1431: newline, adam@1431: p_typ env disc, adam@1431: space, adam@1431: string "disc", adam@1431: space, adam@1431: string "=", adam@1431: space, adam@1524: p_exp' false false env e, adam@1431: string ";", adam@1431: newline, adam@1431: newline, adam@1431: foldr (fn ((p, e), body) => adam@1431: let adam@1431: val pm = p_patMatch (env, "disc") p adam@1516: val (pb, env') = p_patBind (env, "disc") p adam@1431: in adam@1431: box [pm, adam@1431: space, adam@1431: string "?", adam@1431: space, adam@1516: if E.countERels env' = E.countERels env then adam@1524: p_exp' false tail env e adam@1516: else adam@1516: box [string "({", adam@1516: pb, adam@1524: p_exp' false tail env' e, adam@1516: string ";", adam@1516: newline, adam@1516: string "})"], adam@1431: newline, adam@1431: space, adam@1431: string ":", adam@1431: space, adam@1431: body] adam@1431: end) (box [string "({", adam@1431: newline, adam@1431: p_typ env result, adam@1431: space, adam@1431: string "tmp;", adam@1431: newline, adam@1431: string "uw_error(ctx, FATAL, \"", adam@1431: string (ErrorMsg.spanToString loc), adam@1431: string ": pattern match failure\");", adam@1431: newline, adam@1431: string "tmp;", adam@1431: newline, adam@1431: string "})"]) pes, adam@1431: string ";", adam@1431: newline, adam@1431: string "})"] adamc@181: adamc@311: | EWrite e => box [string "(uw_write(ctx, ", adam@1524: p_exp' false false env e, adam@1431: string "), 0)"] adamc@102: adam@1391: | ESeq (e1, e2) => adam@1391: let adam@1391: val useRegion = potentiallyFancy e1 adam@1391: in adam@1391: box [string "(", adam@1391: if useRegion then adam@1391: box [string "uw_begin_region(ctx),", adam@1391: space] adam@1391: else adam@1391: box [], adam@1524: p_exp' false false env e1, adam@1391: string ",", adam@1391: space, adam@1391: if useRegion then adam@1391: box [string "uw_end_region(ctx),", adam@1391: space] adam@1391: else adam@1391: box [], adam@1524: p_exp' false tail env e2, adam@1391: string ")"] adam@1391: end adam@1391: | ELet (x, t, e1, e2) => adam@1391: let adam@1391: val useRegion = notLeaky env false t andalso potentiallyFancy e1 adam@1391: in adam@1391: box [string "({", adam@1391: newline, adam@1391: p_typ env t, adam@1391: space, adam@1391: string "__uwr_", adam@1391: p_ident x, adam@1391: string "_", adam@1391: string (Int.toString (E.countERels env)), adam@1391: space, adam@1391: string "=", adam@1391: space, adam@1391: if useRegion then adam@1391: box [string "(uw_begin_region(ctx),", adam@1391: space] adam@1391: else adam@1391: box [], adam@1524: p_exp' false false env e1, adam@1391: if useRegion then adam@1391: string ")" adam@1391: else adam@1391: box [], adam@1391: string ";", adam@1391: newline, adam@1391: if useRegion then adam@1391: box [string "uw_end_region(ctx);", adam@1391: newline] adam@1391: else adam@1391: box [], adam@1524: p_exp' false tail (E.pushERel env x t) e2, adam@1391: string ";", adam@1391: newline, adam@1391: string "})"] adam@1391: end adamc@269: adamc@282: | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => adamc@278: let adamc@316: val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps adamc@278: val tables = ListUtil.mapConcat (fn (x, xts) => adamc@316: map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts) adamc@278: tables adamc@638: adamc@1168: val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) adamc@1168: val outputs = sort exps @ sort tables adamc@324: adamc@324: val wontLeakStrings = notLeaky env true state adamc@324: val wontLeakAnything = notLeaky env false state adamc@867: adamc@867: val inputs = adamc@867: case prepared of adamc@867: NONE => [] adamc@867: | SOME _ => getPargs query adamc@867: adamc@867: fun doCols p_getcol = adamc@867: box [string "struct __uws_", adamc@867: string (Int.toString rnum), adamc@867: string " __uwr_r_", adamc@867: string (Int.toString (E.countERels env)), adamc@867: string ";", adamc@867: newline, adamc@867: p_typ env state, adamc@867: space, adamc@867: string "__uwr_acc_", adamc@867: string (Int.toString (E.countERels env + 1)), adamc@867: space, adamc@867: string "=", adamc@867: space, adamc@867: string "acc;", adamc@867: newline, adamc@867: newline, adamc@1114: adamc@1114: if Settings.getDeadlines () then adamc@1114: box [string "uw_check_deadline(ctx);", adamc@1114: newline] adamc@1114: else adamc@1114: box [], adamc@1114: adamc@867: p_list_sepi (box []) (fn i => adamc@867: fn (proj, t) => adamc@867: box [string "__uwr_r_", adamc@867: string (Int.toString (E.countERels env)), adamc@867: string ".", adamc@867: string proj, adamc@867: space, adamc@867: string "=", adamc@867: space, adamc@880: p_getcol {loc = loc, adamc@880: wontLeakStrings = wontLeakStrings, adamc@867: col = i, adamc@867: typ = sql_type_in env t}, adamc@867: string ";", adamc@867: newline]) outputs, adamc@867: newline, adamc@867: newline, adamc@867: adamc@867: string "acc", adamc@867: space, adamc@867: string "=", adamc@867: space, adam@1524: p_exp' false false (E.pushERel adam@1524: (E.pushERel env "r" (TRecord rnum, loc)) adam@1524: "acc" state) adam@1524: body, adamc@867: string ";", adamc@867: newline] adamc@278: in adamc@640: box [if wontLeakAnything then adamc@704: string "(uw_begin_region(ctx), " adamc@324: else adamc@324: box [], adamc@324: string "({", adamc@278: newline, adamc@640: p_typ env state, adamc@640: space, adamc@640: string "acc", adamc@640: space, adamc@640: string "=", adamc@640: space, adam@1524: p_exp' false false env initial, adamc@640: string ";", adamc@640: newline, adamc@867: string "int dummy = (uw_begin_region(ctx), 0);", adamc@640: newline, adamc@640: adamc@282: case prepared of adamc@867: NONE => adamc@867: box [string "char *query = ", adam@1524: p_exp' false false env query, adamc@867: string ";", adamc@867: newline, adamc@867: newline, adamc@282: adamc@867: #query (Settings.currentDbms ()) adamc@867: {loc = loc, adamc@873: cols = map (fn (_, t) => sql_type_in env t) outputs, adamc@867: doCols = doCols}] adamc@879: | SOME {id, query, nested} => adamc@867: box [p_list_sepi newline adamc@867: (fn i => fn (e, t) => adamc@867: box [p_sql_type t, adamc@867: space, adamc@867: string "arg", adamc@867: string (Int.toString (i + 1)), adamc@867: space, adamc@867: string "=", adamc@867: space, adam@1524: p_exp' false false env e, adamc@867: string ";"]) adamc@867: inputs, adamc@867: newline, adamc@867: newline, adamc@640: adamc@867: #queryPrepared (Settings.currentDbms ()) adamc@867: {loc = loc, adamc@867: id = id, adamc@867: query = query, adamc@867: inputs = map #2 inputs, adamc@873: cols = map (fn (_, t) => sql_type_in env t) outputs, adamc@879: doCols = doCols, adamc@879: nested = nested}], adamc@278: newline, adamc@277: adamc@324: if wontLeakAnything then adamc@324: box [string "uw_end_region(ctx);", adamc@324: newline] adamc@324: else adamc@324: box [], adamc@278: string "acc;", adamc@278: newline, adamc@704: string "})", adamc@704: if wontLeakAnything then adamc@704: string ")" adamc@704: else adamc@704: box []] adamc@278: end adamc@106: adam@1293: | EDml {dml, prepared, mode} => adam@1295: box [string "(uw_begin_region(ctx), ({", adamc@307: newline, adamc@307: case prepared of adamc@307: NONE => box [string "char *dml = ", adam@1524: p_exp' false false env dml, adamc@307: string ";", adamc@868: newline, adamc@868: newline, adam@1293: #dml (Settings.currentDbms ()) (loc, mode)] adamc@879: | SOME {id, dml = dml'} => adamc@307: let adamc@868: val inputs = getPargs dml adamc@307: in adamc@307: box [p_list_sepi newline adamc@307: (fn i => fn (e, t) => adamc@307: box [p_sql_type t, adamc@307: space, adamc@307: string "arg", adamc@307: string (Int.toString (i + 1)), adamc@307: space, adamc@307: string "=", adamc@307: space, adam@1524: p_exp' false false env e, adamc@307: string ";"]) adamc@868: inputs, adamc@307: newline, adamc@307: newline, adamc@307: adamc@868: #dmlPrepared (Settings.currentDbms ()) {loc = loc, adamc@868: id = id, adamc@868: dml = dml', adam@1293: inputs = map #2 inputs, adam@1293: mode = mode}] adamc@307: end, adamc@307: newline, adamc@307: newline, adamc@337: string "uw_end_region(ctx);", adamc@337: newline, adam@1293: adam@1293: case mode of adam@1431: Settings.Error => string "0;" adam@1295: | Settings.None => string "uw_dup_and_clear_error_message(ctx);", adam@1293: adamc@307: newline, adam@1295: string "}))"] adamc@307: adamc@338: | ENextval {seq, prepared} => adamc@878: box [string "({", adamc@878: newline, adamc@878: string "uw_Basis_int n;", adamc@878: newline, adamc@869: adamc@878: case prepared of adamc@878: NONE => #nextval (Settings.currentDbms ()) {loc = loc, adam@1524: seqE = p_exp' false false env seq, adamc@878: seqName = case #1 seq of adamc@878: EPrim (Prim.String s) => SOME s adamc@878: | _ => NONE} adamc@879: | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, adamc@878: id = id, adamc@878: query = query}, adamc@878: newline, adamc@878: newline, adamc@869: adamc@878: string "n;", adamc@878: newline, adamc@878: string "})"] adamc@338: adamc@1073: | ESetval {seq, count} => adamc@1073: box [string "({", adamc@1073: newline, adamc@1073: adamc@1073: #setval (Settings.currentDbms ()) {loc = loc, adam@1524: seqE = p_exp' false false env seq, adam@1524: count = p_exp' false false env count}, adamc@1073: newline, adamc@1073: newline, adamc@1073: adam@1431: string "0;", adamc@1073: newline, adamc@1073: string "})"] adamc@1073: adamc@1112: | EUnurlify (e, t, true) => adamc@463: let adamc@463: fun getIt () = adamc@463: if isUnboxable t then adamc@1023: unurlify false env t adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: string " *tmp = uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp = ", adamc@1023: unurlify false env t, adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@463: in adamc@463: box [string "({", adamc@463: newline, adamc@737: string "uw_Basis_string request = uw_maybe_strdup(ctx, ", adam@1524: p_exp' false false env e, adamc@492: string ");", adamc@463: newline, adamc@463: newline, adamc@463: string "(request ? ", adamc@463: getIt (), adamc@463: string " : NULL);", adamc@463: newline, adamc@463: string "})"] adamc@463: end adamc@463: adamc@1112: | EUnurlify (e, t, false) => adamc@1112: let adamc@1112: fun getIt () = adamc@1112: if isUnboxable t then adamc@1112: unurlify false env t adamc@1112: else adamc@1112: box [string "({", adamc@1112: newline, adamc@1112: p_typ env t, adamc@1112: string " *tmp = uw_malloc(ctx, sizeof(", adamc@1112: p_typ env t, adamc@1112: string "));", adamc@1112: newline, adamc@1112: string "*tmp = ", adamc@1112: unurlify false env t, adamc@1112: string ";", adamc@1112: newline, adamc@1112: string "tmp;", adamc@1112: newline, adamc@1112: string "})"] adamc@1112: in adamc@1112: box [string "({", adamc@1112: newline, adamc@1112: string "uw_Basis_string request = uw_maybe_strdup(ctx, ", adam@1524: p_exp' false false env e, adamc@1112: string ");", adamc@1112: newline, adamc@1112: newline, adamc@1112: unurlify false env t, adamc@1112: string ";", adamc@1112: newline, adamc@1112: string "})"] adamc@1112: end adamc@1112: adam@1524: and p_exp env = p_exp' false true env adamc@29: adamc@1114: fun p_fun isRec env (fx, n, args, ran, e) = adamc@129: let adamc@129: val nargs = length args adamc@129: val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args adamc@129: in adamc@129: box [string "static", adamc@129: space, adamc@129: p_typ env ran, adamc@129: space, adamc@316: string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), adamc@129: string "(", adamc@129: p_list_sep (box [string ",", space]) (fn x => x) adamc@311: (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => adamc@129: box [p_typ env dom, adamc@129: space, adamc@129: p_rel env' (nargs - i - 1)]) args), adamc@129: string ")", adamc@129: space, adamc@129: string "{", adam@1524: if isRec then adam@1524: box [string "restart:", adam@1524: newline] adam@1524: else adam@1524: box [], adamc@129: newline, adamc@1114: if isRec andalso Settings.getDeadlines () then adamc@1114: box [string "uw_check_deadline(ctx);", adamc@1114: newline] adamc@1114: else adamc@1114: box [], adamc@638: box [string "return(", adamc@638: p_exp env' e, adamc@638: string ");"], adamc@129: newline, adamc@129: string "}"] adamc@129: end adamc@129: adamc@129: fun p_decl env (dAll as (d, _) : decl) = adamc@29: case d of adamc@29: DStruct (n, xts) => adamc@196: let adamc@196: val env = E.declBinds env dAll adamc@196: in adamc@196: box [string "struct", adamc@196: space, adamc@311: string ("__uws_" ^ Int.toString n), adamc@196: space, adamc@196: string "{", adamc@196: newline, adamc@196: p_list_sep (box []) (fn (x, t) => box [p_typ env t, adamc@196: space, adamc@311: string "__uwf_", adamc@316: p_ident x, adamc@196: string ";", adamc@196: newline]) xts, adamc@196: string "};"] adamc@196: end adamc@809: | DDatatype dts => adamc@165: let adamc@809: val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) => adamc@809: dk1 = Enum andalso dk2 <> Enum) dts adamc@809: adamc@809: fun p_one (Enum, x, n, xncs) = adamc@809: box [string "enum", adamc@809: space, adamc@809: string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), adamc@809: space, adamc@809: string "{", adamc@809: space, adam@1298: case xncs of adam@1298: [] => string ("__uwec_" ^ ident x ^ "_" ^ Int.toString n) adam@1298: | _ => adam@1298: p_list_sep (box [string ",", space]) (fn (x, n, _) => adam@1298: string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs, adamc@809: space, adamc@809: string "};"] adamc@809: | p_one (Option, _, _, _) = box [] adamc@809: | p_one (Default, x, n, xncs) = adamc@809: let adamc@809: val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE adamc@809: | (x, n, SOME t) => SOME (x, n, t)) xncs adamc@809: in adamc@809: box [string "enum", adamc@809: space, adamc@809: string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), adamc@809: space, adamc@809: string "{", adamc@809: space, adamc@809: p_list_sep (box [string ",", space]) (fn (x, n, _) => adamc@809: string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) adamc@809: xncs, adamc@809: space, adamc@809: string "};", adamc@809: newline, adamc@809: newline, adamc@809: string "struct", adamc@809: space, adamc@809: string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n), adamc@809: space, adamc@809: string "{", adamc@809: newline, adamc@809: string "enum", adamc@809: space, adamc@809: string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), adamc@809: space, adamc@809: string "tag;", adamc@809: newline, adamc@809: box (case xncsArgs of adamc@809: [] => [] adamc@809: | _ => [string "union", adamc@809: space, adamc@809: string "{", adamc@809: newline, adamc@809: p_list_sep newline (fn (x, n, t) => box [p_typ env t, adamc@809: space, adamc@809: string ("uw_" ^ ident x), adamc@809: string ";"]) xncsArgs, adamc@809: newline, adamc@809: string "}", adamc@809: space, adamc@809: string "data;", adamc@809: newline]), adamc@809: string "};"] adamc@809: end adamc@165: in adamc@809: p_list_sep (box []) p_one dts adamc@188: end adamc@29: adamc@196: | DDatatypeForward _ => box [] adamc@196: adamc@29: | DVal (x, n, t, e) => adamc@29: box [p_typ env t, adamc@29: space, adamc@316: string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n), adamc@29: space, adamc@29: string "=", adamc@29: space, adamc@29: p_exp env e, adamc@29: string ";"] adamc@1114: | DFun vi => p_fun false env vi adamc@129: | DFunRec vis => adamc@29: let adamc@129: val env = E.declBinds env dAll adamc@29: in adamc@129: box [p_list_sep newline (fn (fx, n, args, ran, _) => adamc@129: box [string "static", adamc@129: space, adamc@129: p_typ env ran, adamc@129: space, adamc@316: string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), adamc@311: string "(uw_context,", adamc@129: space, adamc@129: p_list_sep (box [string ",", space]) adamc@129: (fn (_, dom) => p_typ env dom) args, adamc@129: string ");"]) vis, adamc@29: newline, adam@1524: p_list_sep newline (fn vi as (_, n, _, _, _) => adam@1524: (self := SOME n; adam@1524: p_fun true env vi adam@1524: before self := NONE)) vis, adamc@129: newline] adamc@29: end adamc@707: | DTable (x, _, pk, csts) => box [string "/* SQL table ", adamc@707: string x, adamc@707: space, adamc@707: case pk of adamc@707: "" => box [] adamc@707: | _ => box [string "keys", adamc@707: space, adamc@707: string pk, adamc@707: space], adamc@707: string "constraints", adamc@707: space, adamc@707: p_list (fn (x, v) => box [string x, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: string v]) csts, adamc@707: space, adamc@707: string " */", adamc@707: newline] adamc@338: | DSequence x => box [string "/* SQL sequence ", adamc@338: string x, adamc@338: string " */", adamc@338: newline] adamc@754: | DView (x, _, s) => box [string "/* SQL view ", adamc@754: string x, adamc@754: space, adamc@754: string "AS", adamc@754: space, adamc@754: string s, adamc@754: space, adamc@754: string " */", adamc@754: newline] adamc@870: | DDatabase _ => box [] adamc@870: | DPreparedStatements _ => box [] adamc@282: adamc@569: | DJavaScript s => box [string "static char jslib[] = \"", adam@1285: string (String.toCString s), adamc@569: string "\";"] adamc@725: | DCookie s => box [string "/*", adamc@725: space, adamc@725: string "cookie", adamc@725: space, adamc@725: string s, adamc@725: space, adamc@725: string "*/"] adamc@720: | DStyle s => box [string "/*", adamc@720: space, adamc@720: string "style", adamc@720: space, adamc@720: string s, adamc@720: space, adamc@720: string "*/"] adamc@569: adamc@1075: | DTask _ => box [] adam@1294: | DOnError _ => box [] adamc@1073: adamc@144: datatype 'a search = adamc@144: Found of 'a adamc@144: | NotFound adamc@144: | Error adamc@120: adamc@467: fun p_sqltype'' env (tAll as (t, loc)) = adamc@275: case t of adamc@275: TFfi ("Basis", "int") => "int8" adamc@275: | TFfi ("Basis", "float") => "float8" adamc@275: | TFfi ("Basis", "string") => "text" adamc@275: | TFfi ("Basis", "bool") => "bool" adamc@438: | TFfi ("Basis", "time") => "timestamp" adamc@737: | TFfi ("Basis", "blob") => "bytea" adamc@682: | TFfi ("Basis", "channel") => "int8" adamc@682: | TFfi ("Basis", "client") => "int4" adamc@275: | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; adamc@275: Print.eprefaces' [("Type", p_typ env tAll)]; adamc@275: "ERROR") adamc@275: adamc@467: fun p_sqltype' env (tAll as (t, loc)) = adamc@467: case t of adamc@467: (TOption t, _) => p_sqltype'' env t adamc@467: | _ => p_sqltype'' env t ^ " NOT NULL" adamc@467: adamc@275: fun p_sqltype env t = string (p_sqltype' env t) adamc@101: adamc@467: fun p_sqltype_base' env t = adamc@467: case t of adamc@467: (TOption t, _) => p_sqltype'' env t adamc@467: | _ => p_sqltype'' env t adamc@467: adamc@467: fun p_sqltype_base env t = string (p_sqltype_base' env t) adamc@467: adamc@467: fun is_not_null t = adamc@467: case t of adamc@467: (TOption _, _) => false adamc@467: | _ => true adamc@467: adamc@734: fun sigName fields = adamc@734: let adamc@734: fun inFields s = List.exists (fn (s', _) => s' = s) fields adamc@734: adamc@734: fun getSigName n = adamc@734: let adamc@734: val s = "Sig" ^ Int.toString n adamc@734: in adamc@734: if inFields s then adamc@734: getSigName (n + 1) adamc@734: else adamc@734: s adamc@734: end adamc@734: in adamc@734: if inFields "Sig" then adamc@734: getSigName 0 adamc@734: else adamc@734: "Sig" adamc@734: end adamc@734: adamc@101: fun p_file env (ds, ps) = adamc@29: let adam@1516: val () = (clearUrlHandlers (); adam@1516: unurlifies := IS.empty; adam@1516: urlifies := IS.empty; adam@1524: urlifiesL := IS.empty; adam@1524: self := NONE) adam@1516: adamc@101: val (pds, env) = ListUtil.foldlMap (fn (d, env) => adam@1516: let adam@1516: val d' = p_decl env d adam@1516: in adam@1516: (box (List.revAppend (latestUrlHandlers (), [d'])), adam@1516: E.declBinds env d) adam@1516: end) adamc@101: env ds adamc@144: adamc@779: fun flatFields always (t : typ) = adamc@756: case #1 t of adamc@756: TRecord i => adamc@756: let adamc@756: val xts = E.lookupStruct env i adamc@756: in adamc@779: SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts)) adamc@756: end adamc@759: | TList (_, i) => adamc@759: let adamc@759: val ts = E.lookupStruct env i adamc@759: in adamc@759: case ts of adamc@779: [("1", t'), ("2", _)] => flatFields [] t' adamc@759: | _ => raise Fail "CjrPrint: Bad struct for TList" adamc@759: end adamc@756: | _ => NONE adamc@756: adamc@1104: val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) => adamc@144: case ek of adam@1347: Action eff => adam@1347: (case List.nth (ts, length ts - 2) of adam@1347: (TRecord i, loc) => adam@1347: let adam@1347: val xts = E.lookupStruct env i adam@1347: val extra = case eff of adam@1347: ReadCookieWrite => [sigName xts] adam@1347: | _ => [] adam@1347: in adam@1347: case flatFields extra (TRecord i, loc) of adam@1347: NONE => raise Fail "CjrPrint: flatFields impossible" adam@1347: | SOME fields' => List.revAppend (fields', fields) adam@1347: end adam@1347: | _ => raise Fail "CjrPrint: Last argument of action isn't record") adam@1347: | _ => fields) adamc@756: [] ps adamc@756: adamc@756: val fields = foldl (fn (xts, fields) => adamc@756: let adamc@756: val xtsSet = SS.addList (SS.empty, xts) adamc@756: in adamc@756: foldl (fn (x, fields) => adamc@756: let adamc@756: val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) adamc@756: in adamc@756: SM.insert (fields, x, SS.union (SS.delete (xtsSet, x), adamc@756: xtsSet')) adamc@756: end) fields xts adamc@756: end) adamc@756: SM.empty fields adamc@144: adamc@144: val fnums = SM.foldli (fn (x, xs, fnums) => adamc@144: let adamc@144: val unusable = SS.foldl (fn (x', unusable) => adamc@144: case SM.find (fnums, x') of adamc@144: NONE => unusable adamc@144: | SOME n => IS.add (unusable, n)) adamc@144: IS.empty xs adamc@144: adamc@144: fun findAvailable n = adamc@144: if IS.member (unusable, n) then adamc@144: findAvailable (n + 1) adamc@144: else adamc@144: n adamc@144: in adamc@144: SM.insert (fnums, x, findAvailable 0) adamc@144: end) adamc@144: SM.empty fields adamc@144: adamc@734: val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds adamc@734: adamc@144: fun makeSwitch (fnums, i) = adamc@144: case SM.foldl (fn (n, NotFound) => Found n adamc@144: | (n, Error) => Error adamc@144: | (n, Found n') => if n = n' then adamc@144: Found n' adamc@144: else adamc@144: Error) NotFound fnums of adamc@144: NotFound => box [string "return", adamc@144: space, adamc@144: string "-1;"] adamc@144: | Found n => box [string "return", adamc@144: space, adamc@144: string (Int.toString n), adamc@144: string ";"] adamc@144: | Error => adamc@144: let adamc@144: val cmap = SM.foldli (fn (x, n, cmap) => adamc@144: let adamc@144: val ch = if i < size x then adamc@144: String.sub (x, i) adamc@144: else adamc@144: chr 0 adamc@144: adamc@144: val fnums = case CM.find (cmap, ch) of adamc@144: NONE => SM.empty adamc@144: | SOME fnums => fnums adamc@144: val fnums = SM.insert (fnums, x, n) adamc@144: in adamc@144: CM.insert (cmap, ch, fnums) adamc@144: end) adamc@144: CM.empty fnums adamc@144: adamc@144: val cmap = CM.listItemsi cmap adamc@144: in adamc@144: case cmap of adamc@144: [(_, fnums)] => adamc@144: box [string "if", adamc@144: space, adamc@144: string "(name[", adamc@144: string (Int.toString i), adamc@144: string "]", adamc@144: space, adamc@144: string "==", adamc@144: space, adamc@144: string "0)", adamc@144: space, adamc@144: string "return", adamc@144: space, adamc@144: string "-1;", adamc@144: newline, adamc@144: makeSwitch (fnums, i+1)] adamc@144: | _ => adamc@144: box [string "switch", adamc@144: space, adamc@144: string "(name[", adamc@144: string (Int.toString i), adamc@144: string "])", adamc@144: space, adamc@144: string "{", adamc@144: newline, adamc@144: box (map (fn (ch, fnums) => adamc@144: box [string "case", adamc@144: space, adamc@144: if ch = chr 0 then adamc@144: string "0:" adamc@144: else adamc@144: box [string "'", adamc@144: string (Char.toString ch), adamc@144: string "':"], adamc@144: newline, adamc@144: makeSwitch (fnums, i+1), adamc@144: newline]) cmap), adamc@144: string "default:", adamc@144: newline, adamc@144: string "return", adamc@144: space, adamc@144: string "-1;", adamc@144: newline, adamc@144: string "}"] adamc@144: end adamc@144: adamc@756: fun getInput (x, t) = adamc@756: let adamc@756: val n = case SM.find (fnums, x) of adamc@759: NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums") adamc@756: | SOME n => n adamc@756: adamc@756: val f = case t of adamc@756: (TFfi ("Basis", "bool"), _) => "optional_" adamc@756: | _ => "" adamc@756: in adamc@756: if isFile t then adamc@756: box [string "uw_input_", adamc@756: p_ident x, adamc@756: space, adamc@756: string "=", adamc@756: space, adamc@756: string "uw_get_file_input(ctx, ", adamc@756: string (Int.toString n), adamc@756: string ");", adamc@756: newline] adamc@756: else case #1 t of adamc@756: TRecord i => adamc@756: let adamc@756: val xts = E.lookupStruct env i adamc@756: in adamc@756: box [string "uw_enter_subform(ctx, ", adamc@756: string (Int.toString n), adamc@756: string ");", adamc@756: newline, adamc@756: string "uw_input_", adamc@756: p_ident x, adamc@756: space, adamc@756: string "=", adamc@756: space, adamc@756: string "({", adamc@756: box [p_typ env t, adamc@756: space, adamc@756: string "result;", adamc@756: newline, adamc@756: p_list_sep (box []) adamc@756: (fn (x, t) => adamc@756: box [p_typ env t, adamc@756: space, adamc@756: string "uw_input_", adamc@756: string x, adamc@756: string ";", adamc@756: newline]) adamc@756: xts, adamc@756: newline, adamc@756: p_list_sep (box []) (fn (x, t) => adamc@756: box [getInput (x, t), adamc@756: string "result.__uwf_", adamc@756: string x, adamc@756: space, adamc@756: string "=", adamc@756: space, adamc@756: string "uw_input_", adamc@756: string x, adamc@756: string ";", adamc@756: newline]) adamc@756: xts, adamc@756: newline, adamc@756: string "result;", adamc@756: newline], adamc@756: string "});", adamc@756: newline, adamc@756: string "uw_leave_subform(ctx);"] adamc@756: end adamc@759: | TList (t', i) => adamc@759: let adamc@759: val xts = E.lookupStruct env i adamc@759: val i' = case xts of adamc@759: [("1", (TRecord i', loc)), ("2", _)] => i' adamc@759: | _ => raise Fail "CjrPrint: Bad TList record [2]" adamc@759: val xts = E.lookupStruct env i' adamc@759: in adamc@759: box [string "{", adamc@759: newline, adamc@759: string "int status;", adamc@759: newline, adamc@759: string "uw_input_", adamc@759: p_ident x, adamc@759: space, adamc@759: string "=", adamc@759: space, adamc@759: string "NULL;", adamc@759: newline, adamc@759: string "for (status = uw_enter_subforms(ctx, ", adamc@759: string (Int.toString n), adamc@759: string "); status; status = uw_next_entry(ctx)) {", adamc@759: newline, adamc@759: box [p_typ env t, adamc@759: space, adamc@759: string "result", adamc@759: space, adamc@759: string "=", adamc@759: space, adamc@759: string "uw_malloc(ctx, sizeof(struct __uws_", adamc@759: string (Int.toString i), adamc@759: string "));", adamc@759: newline, adamc@759: box [string "{", adamc@759: p_list_sep (box []) adamc@759: (fn (x, t) => adamc@759: box [p_typ env t, adamc@759: space, adamc@759: string "uw_input_", adamc@759: string x, adamc@759: string ";", adamc@759: newline]) adamc@759: xts, adamc@759: newline, adamc@759: p_list_sep (box []) (fn (x, t) => adamc@759: box [getInput (x, t), adamc@759: string "result->__uwf_1.__uwf_", adamc@759: string x, adamc@759: space, adamc@759: string "=", adamc@759: space, adamc@759: string "uw_input_", adamc@759: string x, adamc@759: string ";", adamc@759: newline]) adamc@759: xts, adamc@759: string "}", adamc@759: newline], adamc@759: newline, adamc@759: string "result->__uwf_2 = uw_input_", adamc@759: p_ident x, adamc@759: string ";", adamc@759: newline, adamc@759: string "uw_input_", adamc@759: p_ident x, adamc@759: string " = result;", adamc@759: newline], adamc@759: string "}}", adamc@759: newline] adamc@759: end adamc@756: | _ => adamc@756: box [string "request = uw_get_", adamc@756: string f, adamc@756: string "input(ctx, ", adamc@756: string (Int.toString n), adamc@756: string ");", adamc@756: newline, adamc@756: string "if (request == NULL)", adamc@756: newline, adamc@756: box [string "uw_error(ctx, FATAL, \"Missing input ", adamc@756: string x, adamc@756: string "\");"], adamc@756: newline, adamc@756: string "uw_input_", adamc@756: p_ident x, adamc@756: space, adamc@756: string "=", adamc@756: space, adamc@1023: unurlify true env t, adamc@756: string ";", adamc@756: newline] adamc@756: end adamc@756: adamc@1104: fun p_page (ek, s, n, ts, ran, side, tellSig) = adamc@144: let adamc@734: val (ts, defInputs, inputsVar, fields) = adamc@144: case ek of adam@1347: Core.Action _ => adam@1347: (case List.nth (ts, length ts - 2) of adam@1347: (TRecord i, _) => adam@1347: let adam@1347: val xts = E.lookupStruct env i adam@1347: in adam@1347: (List.take (ts, length ts - 2), adam@1347: box [box (map (fn (x, t) => box [p_typ env t, adam@1347: space, adam@1347: string "uw_input_", adam@1347: p_ident x, adam@1347: string ";", adam@1347: newline]) xts), adam@1347: newline, adam@1347: box (map getInput xts), adam@1431: case i of adam@1431: 0 => string "uw_unit uw_inputs;" adam@1431: | _ => box [string "struct __uws_", adam@1431: string (Int.toString i), adam@1431: space, adam@1431: string "uw_inputs", adam@1431: space, adam@1431: string "= {", adam@1431: newline, adam@1431: box (map (fn (x, _) => box [string "uw_input_", adam@1431: p_ident x, adam@1431: string ",", adam@1431: newline]) xts), adam@1431: string "};"], adam@1347: newline], adam@1347: box [string ",", adam@1347: space, adam@1347: string "uw_inputs"], adam@1347: SOME xts) adam@1347: end adamc@144: adam@1347: | _ => raise Fail "CjrPrint: Last argument to an action isn't a record") adam@1347: | _ => (List.take (ts, length ts - 1), string "", string "", NONE) adamc@734: adamc@734: fun couldWrite ek = adamc@734: case ek of adamc@734: Link => false adamc@735: | Action ef => ef = ReadCookieWrite adamc@735: | Rpc ef => ef = ReadCookieWrite adam@1384: | Extern _ => false adamc@863: adamc@863: val s = adamc@863: case Settings.getUrlPrefix () of adamc@863: "" => s adamc@863: | "/" => s adamc@863: | prefix => adamc@863: if size s > 0 andalso String.sub (s, 0) = #"/" then adamc@863: prefix ^ String.extract (s, 1, NONE) adamc@863: else adamc@863: prefix ^ s adamc@144: in adamc@735: box [string "if (!strncmp(request, \"", adam@1285: string (String.toCString s), adamc@735: string "\", ", adamc@735: string (Int.toString (size s)), adamc@735: string ") && (request[", adamc@735: string (Int.toString (size s)), adamc@735: string "] == 0 || request[", adamc@735: string (Int.toString (size s)), adamc@735: string "] == '/')) {", adamc@735: newline, adamc@735: string "request += ", adamc@735: string (Int.toString (size s)), adamc@735: string ";", adamc@735: newline, adamc@735: string "if (*request == '/') ++request;", adamc@735: newline, adam@1478: if couldWrite ek andalso not (Settings.checkNoXsrfProtection s) then adamc@734: box [string "{", adamc@734: newline, adamc@734: string "uw_Basis_string sig = ", adamc@734: case fields of adamc@734: NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")" adamc@734: | SOME fields => adamc@734: case SM.find (fnums, sigName fields) of adamc@734: NONE => raise Fail "CjrPrint: sig name wasn't assigned a number" adamc@734: | SOME inum => adamc@734: string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"), adamc@734: string ";", adamc@734: newline, adamc@734: string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");", adamc@734: newline, adam@1512: string "if (!uw_streq(sig, uw_cookie_sig(ctx)))", adamc@734: newline, adamc@734: box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");", adamc@734: newline], adamc@734: string "}", adamc@734: newline] adamc@734: else adamc@734: box [], adamc@609: box (case ek of adamc@731: Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");", adamc@731: newline] adamc@609: | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", adamc@609: newline, adamc@609: string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", adamc@609: newline, adamc@804: string "uw_write(ctx, begin_xhtml);", adamc@643: newline, adam@1451: string "uw_mayReturnIndirectly(ctx);", adam@1451: newline, adamc@643: string "uw_set_script_header(ctx, \"", adamc@812: let adamc@812: val scripts = adamc@812: case side of adamc@693: ServerOnly => "" adamc@1111: | _ => adamc@1111: let adamc@1111: val scripts = kkallio@1456: "\\n" adamc@1111: in adamc@1111: foldl (fn (x, scripts) => adamc@1111: scripts kkallio@1456: ^ "\\n") adamc@1111: scripts (Settings.getScripts ()) adamc@1111: end adamc@812: in adamc@812: string scripts adamc@812: end, adamc@643: string "\");", adamc@609: newline]), adamc@1038: string "uw_set_needs_push(ctx, ", adamc@1038: string (case side of adamc@1038: ServerAndPullAndPush => "1" adamc@1038: | _ => "0"), adamc@1038: string ");", adamc@1038: newline, adamc@736: string "uw_set_needs_sig(ctx, ", adamc@1104: string (if tellSig then adamc@736: "1" adamc@736: else adamc@736: "0"), adamc@736: string ");", adamc@736: newline, adamc@682: string "uw_login(ctx);", adamc@682: newline, adamc@144: box [string "{", adamc@144: newline, adamc@144: box (ListUtil.mapi (fn (i, t) => box [p_typ env t, adamc@144: space, adamc@144: string "arg", adamc@144: string (Int.toString i), adamc@144: space, adamc@144: string "=", adamc@144: space, adam@1347: case #1 t of adam@1347: TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)" adam@1370: | TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)" adam@1347: | _ => unurlify false env t, adamc@144: string ";", adamc@144: newline]) ts), adamc@144: defInputs, adamc@609: box (case ek of adamc@731: Core.Rpc _ => [p_typ env ran, adamc@731: space, adamc@731: string "it0", adamc@731: space, adamc@731: string "=", adamc@731: space] adamc@609: | _ => []), adamc@144: p_enamed env n, adamc@144: string "(", adamc@144: p_list_sep (box [string ",", space]) adamc@144: (fn x => x) adamc@272: (string "ctx" adamc@280: :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), adamc@144: inputsVar, adam@1431: string ", 0);", adamc@144: newline, adamc@609: box (case ek of adam@1446: Core.Rpc _ => [string "uw_write(ctx, uw_get_real_script(ctx));", adam@1446: newline, adam@1446: string "uw_write(ctx, \"\\n\");", adam@1446: newline, adam@1446: urlify env ran] adamc@609: | _ => [string "uw_write(ctx, \"\");", adamc@609: newline]), adamc@144: string "return;", adamc@144: newline, adamc@144: string "}", adamc@144: newline, adamc@144: string "}"] adamc@144: ] adamc@144: end adamc@144: adam@1516: val (pds', handlers) = ListUtil.foldlMap (fn (p, handlers) => adam@1516: let adam@1516: val p' = p_page p adam@1516: in adam@1516: (p', latestUrlHandlers () @ handlers) adam@1516: end) [] ps adam@1516: adamc@870: val hasDb = ref false adamc@870: val tables = ref [] adamc@872: val views = ref [] adamc@870: val sequences = ref [] adamc@870: val dbstring = ref "" adamc@870: val expunge = ref 0 adamc@870: val initialize = ref 0 adamc@870: val prepped = ref [] adamc@275: adamc@870: val () = app (fn d => adamc@870: case #1 d of adamc@870: DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true; adamc@870: dbstring := x; adamc@870: expunge := y; adamc@870: initialize := z) adamc@870: | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) => adamc@870: (x, sql_type_in env t)) xts) :: !tables adamc@872: | DView (s, xts, _) => views := (s, map (fn (x, t) => adamc@872: (x, sql_type_in env t)) xts) :: !views adamc@870: | DSequence s => sequences := s :: !sequences adamc@870: | DPreparedStatements ss => prepped := ss adamc@870: | _ => ()) ds adamc@377: adam@1381: val hasDb = !hasDb adam@1381: adam@1381: fun expDb (e, _) = adam@1381: case e of adam@1381: ECon (_, _, SOME e) => expDb e adam@1381: | ESome (_, e) => expDb e adam@1381: | EFfiApp (_, _, es) => List.exists expDb es adam@1381: | EApp (e, es) => expDb e orelse List.exists expDb es adam@1381: | EUnop (_, e) => expDb e adam@1381: | EBinop (_, e1, e2) => expDb e1 orelse expDb e2 adam@1381: | ERecord (_, xes) => List.exists (expDb o #2) xes adam@1381: | EField (e, _) => expDb e adam@1381: | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes adam@1381: | EError (e, _) => expDb e adam@1381: | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2 adam@1381: | ERedirect (e, _) => expDb e adam@1381: | EWrite e => expDb e adam@1381: | ESeq (e1, e2) => expDb e1 orelse expDb e2 adam@1381: | ELet (_, _, e1, e2) => expDb e1 orelse expDb e2 adam@1381: | EQuery _ => true adam@1381: | EDml _ => true adam@1381: | ENextval _ => true adam@1381: | ESetval _ => true adam@1381: | EUnurlify (e, _, _) => expDb e adam@1381: | _ => false adam@1381: adam@1381: fun declDb (d, _) = adam@1381: case d of adam@1381: DVal (_, _, _, e) => expDb e adam@1381: | DFun (_, _, _, _, e) => expDb e adam@1381: | DFunRec vis => List.exists (expDb o #5) vis adam@1381: | _ => false adam@1381: adam@1381: val () = if not hasDb andalso List.exists declDb ds then adam@1381: ErrorMsg.error "Application uses a database but has none configured with 'database' in .urp file." adam@1381: else adam@1381: () adamc@734: adamc@734: val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds adamc@734: adamc@734: val cookieCode = foldl (fn (cookie, acc) => adamc@734: SOME (case acc of adamc@734: NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \"" adamc@734: ^ cookie ^ "\"))") adamc@734: | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \"" adamc@734: ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "), adamc@734: acc, adamc@734: string "))"])) adamc@734: NONE cookies adamc@770: adamc@770: fun makeChecker (name, rules : Settings.rule list) = adamc@1094: box [string "static int ", adamc@770: string name, adamc@770: string "(const char *s) {", adamc@770: newline, adamc@770: box [p_list_sep (box []) adamc@770: (fn rule => adamc@770: box [string "if (!str", adamc@770: case #kind rule of adamc@770: Settings.Exact => box [string "cmp(s, \"", adam@1285: string (String.toCString (#pattern rule)), adamc@770: string "\"))"] adamc@770: | Settings.Prefix => box [string "ncmp(s, \"", adam@1285: string (String.toCString (#pattern rule)), adamc@770: string "\", ", adamc@770: string (Int.toString (size (#pattern rule))), adamc@770: string "))"], adamc@770: string " return ", adamc@770: string (case #action rule of adamc@770: Settings.Allow => "1" adamc@770: | Settings.Deny => "0"), adamc@770: string ";", adamc@770: newline]) rules, adamc@770: string "return 0;", adamc@770: newline], adamc@770: string "}", adamc@770: newline] adamc@1073: adam@1348: val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds adam@1348: val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds adam@1349: val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds adamc@1263: adam@1294: val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds adam@1294: adamc@1263: val now = Time.now () adamc@1263: val nowD = Date.fromTimeUniv now adamc@1263: val rfcFmt = "%a, %d %b %Y %H:%M:%S" adamc@29: in adamc@1263: box [string "#include \"", adamc@1263: string (OS.Path.joinDirFile {dir = Config.includ, adamc@1263: file = "config.h"}), adamc@1263: string "\"", adamc@1263: newline, adamc@1263: string "#include ", adamc@144: newline, adamc@144: string "#include ", adamc@144: newline, adamc@272: string "#include ", adamc@272: newline, adamc@390: string "#include ", adamc@390: newline, adamc@1263: string "#include ", adamc@1263: newline, adamc@432: if hasDb then adamc@866: box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), adamc@432: newline] adamc@432: else adamc@432: box [], adamc@764: p_list_sep (box []) (fn s => box [string "#include \"", adamc@764: string s, adamc@764: string "\"", adamc@764: newline]) (Settings.getHeaders ()), adamc@378: string "#include \"", adamc@378: string (OS.Path.joinDirFile {dir = Config.includ, adamc@378: file = "urweb.h"}), adamc@378: string "\"", adamc@101: newline, adamc@101: newline, adamc@804: adam@1307: box [string "static void uw_setup_limits() {", adam@1307: newline, adam@1332: case Settings.getMinHeap () of adam@1332: 0 => box [] adam@1332: | n => box [string "uw_min_heap", adam@1332: space, adam@1332: string "=", adam@1332: space, adam@1332: string (Int.toString n), adam@1332: string ";", adam@1332: newline, adam@1332: newline], adam@1307: box [p_list_sep (box []) (fn (class, num) => adam@1307: let adam@1307: val num = case class of adam@1307: "page" => Int.max (2048, num) adam@1307: | _ => num adam@1307: in adam@1307: box [string ("uw_" ^ class ^ "_max"), adam@1307: space, adam@1307: string "=", adam@1307: space, adam@1307: string (Int.toString num), adam@1307: string ";", adam@1307: newline] adam@1307: end) (Settings.limits ())], adam@1307: string "}", adam@1307: newline, adam@1307: newline], adam@1307: adamc@1164: #code (Settings.currentProtocol ()) (), adamc@1164: adamc@870: if hasDb then adamc@870: #init (Settings.currentDbms ()) {dbstring = !dbstring, adamc@870: prepared = !prepped, adamc@870: tables = !tables, adamc@872: views = !views, adamc@870: sequences = !sequences} adamc@870: else adam@1307: box [string "static void uw_client_init(void) { };", adamc@891: newline, adam@1307: string "static void uw_db_init(uw_context ctx) { };", adamc@870: newline, adam@1307: string "static int uw_db_begin(uw_context ctx) { return 0; };", adamc@870: newline, adam@1307: string "static void uw_db_close(uw_context ctx) { };", adamc@1094: newline, adam@1307: string "static int uw_db_commit(uw_context ctx) { return 0; };", adamc@870: newline, adam@1307: string "static int uw_db_rollback(uw_context ctx) { return 0; };"], adamc@870: newline, adamc@870: newline, adamc@870: adam@1407: string "static const char begin_xhtml[] = \"\\n\\n\";", adam@1407: newline, adam@1407: newline, adam@1407: adam@1407: p_list_sep newline (fn x => x) pds, adam@1407: newline, adam@1407: newline, adam@1407: string "static int uw_input_num(const char *name) {", adam@1407: newline, adam@1407: makeSwitch (fnums, 0), adam@1407: string "}", adam@1407: newline, adam@1407: newline, adam@1407: adam@1349: box (ListUtil.mapi (fn (i, (_, x1, x2, e)) => adam@1349: box [string "static void uw_periodic", adam@1349: string (Int.toString i), adam@1349: string "(uw_context ctx) {", adam@1349: newline, adam@1349: box [string "uw_unit __uwr_", adam@1349: string x1, adam@1431: string "_0 = 0, __uwr_", adam@1349: string x2, adam@1431: string "_1 = 0;", adam@1349: newline, adam@1349: p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, adam@1349: string ";", adam@1349: newline], adam@1349: string "}", adam@1349: newline, adam@1349: newline]) periodics), adam@1349: adam@1349: string "static uw_periodic my_periodics[] = {", adam@1349: box (ListUtil.mapi (fn (i, (n, _, _, _)) => adam@1349: box [string "{uw_periodic", adam@1349: string (Int.toString i), adam@1349: string ",", adam@1349: space, adam@1349: string (Int64.toString n), adam@1349: string "},"]) periodics), adam@1349: string "{NULL}};", adam@1349: newline, adam@1349: newline, adam@1349: adamc@770: makeChecker ("uw_check_url", Settings.getUrlRules ()), adamc@770: newline, adamc@770: adamc@770: makeChecker ("uw_check_mime", Settings.getMimeRules ()), adamc@770: newline, adam@1465: adam@1465: makeChecker ("uw_check_requestHeader", Settings.getRequestHeaderRules ()), adam@1465: newline, adam@1465: adam@1465: makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()), adam@1465: newline, adamc@734: adamc@734: string "extern void uw_sign(const char *in, char *out);", adamc@734: newline, adamc@734: string "extern int uw_hash_blocksize;", adamc@734: newline, adamc@1094: string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {", adamc@734: newline, adamc@734: box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);", adamc@734: newline, adamc@734: string "uw_sign(", adamc@734: case cookieCode of adamc@734: NONE => string "\"\"" adamc@734: | SOME code => code, adamc@734: string ", r);", adamc@734: newline, adamc@734: string "return uw_Basis_makeSigString(ctx, r);", adamc@734: newline], adamc@734: string "}", adamc@734: newline, adamc@734: newline, adamc@734: adam@1516: box (rev handlers), adam@1516: adamc@1094: string "static void uw_handle(uw_context ctx, char *request) {", adamc@101: newline, adamc@863: string "if (!strcmp(request, \"", adamc@863: string (OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), adamc@863: file = "app.js"}), adamc@863: string "\")) {", adamc@569: newline, adamc@1263: box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");", adamc@1263: newline, adamc@1263: string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"), adamc@1263: newline, adamc@1263: box [string "uw_clear_headers(ctx);", adamc@1263: newline, adam@1320: string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");", adamc@1263: newline, adamc@1263: string "return;", adamc@1263: newline], adamc@1263: string "}", adamc@1263: newline, adamc@1263: newline, adamc@1263: string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", adamc@1263: newline, adamc@1263: string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"), adamc@569: newline, adamc@569: string "uw_write(ctx, jslib);", adamc@569: newline, adamc@569: string "return;", adamc@569: newline], adamc@569: string "}", adamc@569: newline, adamc@101: p_list_sep newline (fn x => x) pds', adamc@101: newline, adamc@1110: string "uw_clear_headers(ctx);", adamc@1110: newline, adamc@1110: string "uw_write_header(ctx, \"HTTP/1.1 404 Not Found\\r\\nContent-type: text/plain\\r\\n\");", adamc@1110: newline, adamc@1110: string "uw_write(ctx, \"Not Found\");", adamc@387: newline, adamc@101: string "}", adamc@275: newline, adamc@275: newline, adamc@870: adam@1348: box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {", adam@1348: newline, adam@1348: adam@1348: p_list_sep (box []) (fn (x1, x2, e) => box [string "({", adam@1348: newline, adam@1348: string "uw_Basis_client __uwr_", adam@1348: string x1, adam@1348: string "_0 = cli;", adam@1348: newline, adam@1348: string "uw_unit __uwr_", adam@1348: string x2, adam@1431: string "_1 = 0;", adam@1348: newline, adam@1348: p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) adam@1348: x2 dummyt) e, adam@1348: string ";", adam@1348: newline, adam@1348: string "});", adam@1348: newline]) expungers, adam@1348: adam@1348: if hasDb then adamc@870: box [p_enamed env (!expunge), adamc@870: string "(ctx, cli);", adam@1348: newline] adam@1348: else adam@1348: box [], adam@1348: string "}"], adamc@870: adam@1348: newline, adam@1348: string "static void uw_initializer(uw_context ctx) {", adam@1348: newline, adam@1348: box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({", adam@1348: newline, adam@1348: string "uw_unit __uwr_", adam@1348: string x1, adam@1431: string "_0 = 0, __uwr_", adam@1348: string x2, adam@1431: string "_1 = 0;", adam@1348: newline, adam@1348: p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, adam@1348: string ";", adam@1348: newline, adam@1348: string "});", adam@1348: newline]) initializers, adam@1348: if hasDb then adam@1348: box [p_enamed env (!initialize), adam@1431: string "(ctx, 0);", adam@1348: newline] adam@1348: else adam@1348: box []], adam@1348: string "}", adam@1348: newline, adamc@1094: adam@1294: case onError of adam@1294: NONE => box [] adam@1294: | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {", adam@1294: newline, adam@1483: if Settings.getDebug () then adam@1483: box [] adam@1483: else adam@1483: box [string "uw_cutErrorLocation(msg);", adam@1483: newline], adam@1294: box [string "uw_write(ctx, ", adam@1294: p_enamed env n, adam@1431: string "(ctx, msg, 0));", adam@1294: newline], adam@1294: string "}", adam@1294: newline, adam@1294: newline], adam@1294: adamc@1094: string "uw_app uw_application = {", adamc@1094: p_list_sep (box [string ",", newline]) string adamc@1094: [Int.toString (SM.foldl Int.max 0 fnums + 1), adamc@1094: Int.toString (Settings.getTimeout ()), adamc@1094: "\"" ^ Settings.getUrlPrefix () ^ "\"", adamc@1094: "uw_client_init", "uw_initializer", "uw_expunger", adamc@1094: "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close", adamc@1094: "uw_handle", adam@1465: "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", adam@1349: case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics"], adamc@1094: string "};", adamc@1094: newline] adamc@29: end adamc@29: adamc@274: fun p_sql env (ds, _) = adamc@274: let adamc@274: val (pps, _) = ListUtil.foldlMap adamc@274: (fn (dAll as (d, _), env) => adamc@274: let adamc@274: val pp = case d of adamc@707: DTable (s, xts, pk, csts) => adamc@274: box [string "CREATE TABLE ", adamc@274: string s, adamc@274: string "(", adamc@274: p_list (fn (x, t) => adamc@874: let adamc@874: val t = sql_type_in env t adamc@874: in adamc@874: box [string "uw_", adamc@874: string (CharVector.map Char.toLower x), adamc@874: space, adamc@874: string (#p_sql_type (Settings.currentDbms ()) t), adamc@874: case t of adamc@874: Nullable _ => box [] adamc@874: | _ => string " NOT NULL"] adamc@874: end) xts, adamc@707: case (pk, csts) of adamc@707: ("", []) => box [] adamc@707: | _ => string ",", adamc@704: cut, adamc@707: case pk of adamc@707: "" => box [] adamc@707: | _ => box [string "PRIMARY", adamc@707: space, adamc@707: string "KEY", adamc@707: space, adamc@707: string "(", adamc@707: string pk, adamc@707: string ")", adamc@707: case csts of adamc@707: [] => box [] adamc@707: | _ => string ",", adamc@707: newline], adamc@704: p_list_sep (box [string ",", newline]) adamc@704: (fn (x, c) => adamc@704: box [string "CONSTRAINT", adamc@704: space, adamc@704: string s, adamc@704: string "_", adamc@704: string x, adamc@704: space, adamc@704: string c]) csts, adamc@704: newline, adamc@274: string ");", adamc@274: newline, adamc@274: newline] adamc@338: | DSequence s => adamc@877: box [string (#createSequence (Settings.currentDbms ()) s), adamc@338: string ";", adamc@338: newline, adamc@338: newline] adamc@754: | DView (s, xts, q) => adamc@754: box [string "CREATE VIEW", adamc@754: space, adamc@754: string s, adamc@754: space, adamc@754: string "AS", adamc@754: space, adamc@754: string q, adamc@754: string ";", adamc@754: newline, adamc@754: newline] adamc@274: | _ => box [] adamc@274: in adamc@274: (pp, E.declBinds env dAll) adamc@274: end) adamc@274: env ds adamc@274: in adamc@882: box (string (#sqlPrefix (Settings.currentDbms ())) :: pps) adamc@274: end adamc@274: adamc@29: end