From c2a217f9121dd865122bc6150c53e77bd662050d Mon Sep 17 00:00:00 2001 From: fab Date: Sat, 3 Nov 2018 20:09:20 +0000 Subject: utf-8 aware functions for basis. unit-testing. --- src/compiler.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index f724bf56..9ee88c9b 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1585,9 +1585,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a -licui18n -licuuc -licudata" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a -licui18n -licuuc -licudata" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" -- cgit v1.2.3 From c1932084390aca19c748da024b7b168c160a3aea Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 14 Dec 2018 15:42:59 -0500 Subject: New .urp option: safeGetDefault --- doc/manual.tex | 1 + src/compiler.sig | 1 + src/compiler.sml | 7 +++++++ src/demo.sml | 1 + src/settings.sig | 1 + src/settings.sml | 4 +++- 6 files changed, 14 insertions(+), 1 deletion(-) (limited to 'src/compiler.sml') diff --git a/doc/manual.tex b/doc/manual.tex index d2db4816..e064e59e 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -190,6 +190,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{profile} generates an executable that may be used with gprof. \item \texttt{rewrite KIND FROM TO} gives a rule for rewriting canonical module paths. For instance, the canonical path of a page may be \texttt{Mod1.Mod2.mypage}, while you would rather the page were accessed via a URL containing only \texttt{page}. The directive \texttt{rewrite url Mod1/Mod2/mypage page} would accomplish that. The possible values of \texttt{KIND} determine which kinds of objects are affected. The kind \texttt{all} matches any object, and \texttt{url} matches page URLs. The kinds \texttt{table}, \texttt{sequence}, and \texttt{view} match those sorts of SQL entities, and \texttt{relation} matches any of those three. \texttt{cookie} matches HTTP cookies, and \texttt{style} matches CSS class names. If \texttt{FROM} ends in \texttt{/*}, it is interpreted as a prefix matching rule, and rewriting occurs by replacing only the appropriate prefix of a path with \texttt{TO}. The \texttt{TO} field may be left empty to express the idea of deleting a prefix. For instance, \texttt{rewrite url Main/*} will strip all \texttt{Main/} prefixes from URLs. While the actual external names of relations and styles have parts separated by underscores instead of slashes, all rewrite rules must be written in terms of slashes. An optional suffix of \cd{[-]} for a \cd{rewrite} directive asks to additionally replace all \cd{\_} characters with \cd{-} characters, which can be handy for, e.g., interfacing with an off-the-shelf CSS library that prefers hyphens over underscores. \item \texttt{safeGet URI} asks to allow the page handler assigned this canonical URI prefix to cause persistent side effects, even if accessed via an HTTP \cd{GET} request. +\item \texttt{safeGetDefault} asks to allow \emph{any} page handler to cause side effects, even if accessed via an HTTP \cd{GET} request. \item \texttt{script URL} adds \texttt{URL} to the list of extra JavaScript files to be included at the beginning of any page that uses JavaScript. This is most useful for importing JavaScript versions of functions found in new FFI modules. \item \texttt{serverOnly Module.ident} registers an FFI function or transaction that may only be run on the server. \item \texttt{sigfile PATH} sets a path where your application should look for a key to use in cryptographic signing. This is used to prevent cross-site request forgery attacks for any form handler that both reads a cookie and creates side effects. If the referenced file doesn't exist, an application will create it and read its saved data on future invocations. You can also initialize the file manually with any contents at least 16 bytes long; the first 16 bytes will be treated as the key. diff --git a/src/compiler.sig b/src/compiler.sig index bcf69fd4..7922393d 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -61,6 +61,7 @@ signature COMPILER = sig dbms : string option, sigFile : string option, fileCache : string option, + safeGetDefault : bool, safeGets : string list, onError : (string * string list * string) option, minHeap : int, diff --git a/src/compiler.sml b/src/compiler.sml index f724bf56..271cf2f1 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -65,6 +65,7 @@ type job = { dbms : string option, sigFile : string option, fileCache : string option, + safeGetDefault : bool, safeGets : string list, onError : (string * string list * string) option, minHeap : int, @@ -385,6 +386,7 @@ fun institutionalizeJob (job : job) = Settings.setMetaRules (#filterMeta job); Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); + Settings.setSafeGetDefault (#safeGetDefault job); Settings.setSafeGets (#safeGets job); Settings.setOnError (#onError job); Settings.setMinHeap (#minHeap job); @@ -470,6 +472,7 @@ fun parseUrp' accLibs fname = dbms = NONE, sigFile = NONE, fileCache = NONE, + safeGetDefault = false, safeGets = [], onError = NONE, minHeap = 0, @@ -605,6 +608,7 @@ fun parseUrp' accLibs fname = val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val fileCache = ref (Settings.getFileCache ()) + val safeGetDefault = ref false val safeGets = ref [] val onError = ref NONE val minHeap = ref 0 @@ -645,6 +649,7 @@ fun parseUrp' accLibs fname = dbms = !dbms, sigFile = !sigFile, fileCache = !fileCache, + safeGetDefault = !safeGetDefault, safeGets = rev (!safeGets), onError = !onError, minHeap = !minHeap, @@ -708,6 +713,7 @@ fun parseUrp' accLibs fname = dbms = mergeO #2 (#dbms old, #dbms new), sigFile = mergeO #2 (#sigFile old, #sigFile new), fileCache = mergeO #2 (#fileCache old, #fileCache new), + safeGetDefault = #safeGetDefault old orelse #safeGetDefault new, safeGets = #safeGets old @ #safeGets new, onError = mergeO #2 (#onError old, #onError new), minHeap = Int.max (#minHeap old, #minHeap new), @@ -829,6 +835,7 @@ fun parseUrp' accLibs fname = | "include" => headers := relifyA arg :: !headers | "script" => scripts := arg :: !scripts | "clientToServer" => clientToServer := ffiS () :: !clientToServer + | "safeGetDefault" => safeGetDefault := true | "safeGet" => safeGets := arg :: !safeGets | "effectful" => effectful := ffiS () :: !effectful | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful diff --git a/src/demo.sml b/src/demo.sml index 1e58e2f8..eaec38bb 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -124,6 +124,7 @@ fun make' {prefix, dirname, guided} = dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), fileCache = mergeWith #2 (#fileCache combined, #fileCache urp), + safeGetDefault = #safeGetDefault combined orelse #safeGetDefault urp, safeGets = #safeGets combined @ #safeGets urp, onError = NONE, minHeap = 0, diff --git a/src/settings.sig b/src/settings.sig index 986d6ed7..6ba7e96a 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -258,6 +258,7 @@ signature SETTINGS = sig val getFileCache : unit -> string option (* Which GET-able functions should be allowed to have side effects? *) + val setSafeGetDefault : bool -> unit val setSafeGets : string list -> unit val isSafeGet : string -> bool diff --git a/src/settings.sml b/src/settings.sml index cfbe98a5..3772fc04 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -740,9 +740,11 @@ structure SS = BinarySetFn(struct val compare = String.compare end) +val safeGetDefault = ref false val safeGet = ref SS.empty +fun setSafeGetDefault b = safeGetDefault := b fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) -fun isSafeGet x = SS.member (!safeGet, x) +fun isSafeGet x = !safeGetDefault orelse SS.member (!safeGet, x) val onError = ref (NONE : (string * string list * string) option) fun setOnError x = onError := x -- cgit v1.2.3 From 7578916b630bd84ec3f8e7d97aaaa1cc7828e5ef Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 16 Dec 2018 16:45:37 -0500 Subject: Specialize: ignore recursive references in classifying polymorphic uses of datatypes --- src/compiler.sig | 1 + src/compiler.sml | 3 ++- src/core_util.sig | 6 ++++++ src/core_util.sml | 16 ++++++++++++++++ src/specialize.sml | 34 +++++++++++++++++++++++++++++++--- 5 files changed, 56 insertions(+), 4 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sig b/src/compiler.sig index 7922393d..09c913f8 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -164,6 +164,7 @@ signature COMPILER = sig val toUnpoly2 : (string, Core.file) transform val toShake4'' : (string, Core.file) transform val toEspecialize3 : (string, Core.file) transform + val toSpecialize3 : (string, Core.file) transform val toReduce2 : (string, Core.file) transform val toShake5 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 271cf2f1..e7de4d82 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1390,8 +1390,9 @@ val toUnpoly2 = transform unpoly "unpoly2" o toShake4' val toSpecialize2 = transform specialize "specialize2" o toUnpoly2 val toShake4'' = transform shake "shake4'" o toSpecialize2 val toEspecialize3 = transform especialize "especialize3" o toShake4'' +val toSpecialize3 = transform specialize "specialize3" o toEspecialize3 -val toReduce2 = transform reduce "reduce2" o toEspecialize3 +val toReduce2 = transform reduce "reduce2" o toSpecialize3 val toShake5 = transform shake "shake5" o toReduce2 diff --git a/src/core_util.sig b/src/core_util.sig index 835577a3..8d295f1e 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -161,6 +161,12 @@ structure Decl : sig decl : (Core.decl', 'state, 'abort) Search.mapfolder} -> (Core.decl, 'state, 'abort) Search.mapfolder + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con', + exp : Core.exp' -> Core.exp', + decl : Core.decl' -> Core.decl'} + -> Core.decl -> Core.decl + val fold : {kind : Core.kind' * 'state -> 'state, con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state, diff --git a/src/core_util.sml b/src/core_util.sml index 57ef16f7..d1d3d9c4 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -1029,6 +1029,22 @@ fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} = decl = fn () => fd, bind = fn ((), _) => ()} () +fun mapB {kind, con, exp, decl, bind} ctx d = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), + decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()), + bind = bind} ctx d () of + S.Continue (d, ()) => d + | S.Return _ => raise Fail "CoreUtil.Decl.mapB: Impossible" + +fun map {kind, con, exp, decl} d = + mapB {kind = fn () => kind, + con = fn () => con, + exp = fn () => exp, + decl = fn () => decl, + bind = fn _ => ()} () d + fun fold {kind, con, exp, decl} s d = case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)), con = fn c => fn s => S.Continue (c, con (c, s)), diff --git a/src/specialize.sml b/src/specialize.sml index 9dc2cf1b..70e646e3 100644 --- a/src/specialize.sml +++ b/src/specialize.sml @@ -248,6 +248,27 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} fun specialize file = let + (*val () = CorePrint.debug := true + val () = print "SPECIALIZING\n"*) + + (* Let's run around a file, finding any polymorphic uses of a datatype. + * However, don't count polymorphism within a datatype's own definition! + * To that end, we run a silly transform on the file before traversing. *) + val file' = + map (fn d => + case #1 d of + DDatatype dts => + U.Decl.map {kind = fn x => x, + exp = fn x => x, + decl = fn x => x, + con = fn CNamed n => + if List.exists (fn (_, n', _, _) => n' = n) dts then + CUnit + else + CNamed n + | c => c} d + | _ => d) file + val fancyDatatypes = U.File.fold {kind = fn (_, fd) => fd, exp = fn (_, fd) => fd, decl = fn (_, fd) => fd, @@ -256,12 +277,18 @@ fun specialize file = CApp (c1, c2) => if isOpen c2 then case findApp (c, []) of - SOME (n, _) => IS.add (fd, n) + SOME (n, _) => + ((*Print.preface ("Disqualifier", + CorePrint.p_con CoreEnv.empty (c, ErrorMsg.dummySpan));*) + IS.add (fd, n)) | NONE => fd else fd | _ => fd} - IS.empty file + IS.empty file' + + (* Why did we find the polymorphism? + * It would be incoherent to specialize a datatype used polymorphically. *) fun doDecl (d, st) = let @@ -271,7 +298,8 @@ fun specialize file = case #1 d of DDatatype dts => if List.exists (fn (_, n, _, _) => IS.member (fancyDatatypes, n)) dts then - ([d], st) + ((*Print.preface ("Skipping", CorePrint.p_decl CoreEnv.empty d);*) + ([d], st)) else ((case #decls st of [] => [d] -- cgit v1.2.3 From 757e40719735a45085343e90b53674b9b276b5cb Mon Sep 17 00:00:00 2001 From: fab Date: Mon, 17 Dec 2018 22:25:59 +0000 Subject: test 5 --- configure.ac | 1 + src/compiler.sml | 4 ++-- src/config.sig | 3 +++ src/config.sml.in | 3 +++ src/settings.sig | 1 + src/settings.sml | 2 +- 6 files changed, 11 insertions(+), 3 deletions(-) (limited to 'src/compiler.sml') diff --git a/configure.ac b/configure.ac index bd52aa4c..d6b1c98f 100644 --- a/configure.ac +++ b/configure.ac @@ -126,6 +126,7 @@ AC_SUBST(VERSION) AC_SUBST(PTHREAD_CFLAGS) AC_SUBST(PTHREAD_LIBS) AC_SUBST(ICU_INCLUDES) +AC_SUBST(ICU_LIBS) AC_CONFIG_FILES([ Makefile diff --git a/src/compiler.sml b/src/compiler.sml index 9ee88c9b..06615bcf 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1585,9 +1585,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a -licui18n -licuuc -licudata" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a -licui18n -licuuc -licudata" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" diff --git a/src/config.sig b/src/config.sig index a3ad7d76..be72a8cc 100644 --- a/src/config.sig +++ b/src/config.sig @@ -20,4 +20,7 @@ signature CONFIG = sig val pthreadCflags : string val pthreadLibs : string + + val icuIncludes : string + val icuLibs : string end diff --git a/src/config.sml.in b/src/config.sml.in index ebcdb7b6..2d12e28d 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -28,6 +28,9 @@ val pgheader = "@PGHEADER@" val msheader = "@MSHEADER@" val sqheader = "@SQHEADER@" +val icuIncludes = "@ICU_INCLUDES@" +val icuLibs = "@ICU_LIBS@" + val versionNumber = "@VERSION@" val versionString = "The Ur/Web compiler, version " ^ versionNumber diff --git a/src/settings.sig b/src/settings.sig index 986d6ed7..22dc80a2 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -37,6 +37,7 @@ signature SETTINGS = sig val configSrcLib : string ref val configInclude : string ref val configSitelisp : string ref + val configIcuLibs : string ref val libUr : unit -> string val libC : unit -> string diff --git a/src/settings.sml b/src/settings.sml index cfbe98a5..8ae2d377 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -32,7 +32,7 @@ val configLib = ref Config.lib val configSrcLib = ref Config.srclib val configInclude = ref Config.includ val configSitelisp = ref Config.sitelisp - +val configIcuLibs = ref Config.icuLibs val configCCompiler = ref Config.ccompiler fun getCCompiler () = !configCCompiler -- cgit v1.2.3 From 2d699b85cfb3f137e8963ad9a355918e40b39d62 Mon Sep 17 00:00:00 2001 From: fab Date: Mon, 17 Dec 2018 22:41:16 +0000 Subject: test 6 --- src/compiler.sml | 4 ++-- src/settings.sig | 1 + src/settings.sml | 1 + 3 files changed, 4 insertions(+), 2 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 06615bcf..1f77a821 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1585,9 +1585,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuIncludes ^ " " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuIncludes ^ " " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" diff --git a/src/settings.sig b/src/settings.sig index 22dc80a2..29817467 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -37,6 +37,7 @@ signature SETTINGS = sig val configSrcLib : string ref val configInclude : string ref val configSitelisp : string ref + val configIcuIncludes : string ref val configIcuLibs : string ref val libUr : unit -> string diff --git a/src/settings.sml b/src/settings.sml index 8ae2d377..2e386a4f 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -32,6 +32,7 @@ val configLib = ref Config.lib val configSrcLib = ref Config.srclib val configInclude = ref Config.includ val configSitelisp = ref Config.sitelisp +val configIcuIncludes = ref Config.icuIncludes val configIcuLibs = ref Config.icuLibs val configCCompiler = ref Config.ccompiler -- cgit v1.2.3 From 05029221a3331f3f0392a4a940a84fb930dfe16d Mon Sep 17 00:00:00 2001 From: fab Date: Mon, 17 Dec 2018 22:59:03 +0000 Subject: test 7 --- src/compiler.sml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 1f77a821..faf5bbe6 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1585,9 +1585,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuIncludes ^ " " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuIncludes ^ " " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" @@ -1598,6 +1598,7 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value" ^ opt ^ " -I " ^ !Settings.configInclude + ^ " " ^ !Settings.configIcuIncludes ^ " " ^ #compile proto ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname -- cgit v1.2.3 From e6c93e5b8ed862d096d2120aa0be2a125b332776 Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Mon, 7 Jan 2019 15:54:06 +0200 Subject: -endpoints switch to view all endpoints defined in JSON format --- src/compiler.sig | 1 + src/compiler.sml | 7 +++++ src/endpoints.sig | 41 ++++++++++++++++++++++++++++ src/endpoints.sml | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/main.mlton.sml | 28 +++++++++++++++----- 5 files changed, 148 insertions(+), 7 deletions(-) create mode 100644 src/endpoints.sig create mode 100644 src/endpoints.sml (limited to 'src/compiler.sml') diff --git a/src/compiler.sig b/src/compiler.sig index 09c913f8..d4521b9f 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -171,6 +171,7 @@ signature COMPILER = sig val toEffectize : (string, Core.file) transform val toCss : (string, Css.report) transform val toMonoize : (string, Mono.file) transform + val toEndpoints : (string, Endpoints.report) transform val toMono_opt1 : (string, Mono.file) transform val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 868dd628..4ef9ba19 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1429,6 +1429,13 @@ val mono_opt = { print = MonoPrint.p_file MonoEnv.empty } +val endpoints = { + func = Endpoints.summarize, + print = Endpoints.p_report +} + +val toEndpoints = transform endpoints "endpoints" o toMonoize + val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize val untangle = { diff --git a/src/endpoints.sig b/src/endpoints.sig new file mode 100644 index 00000000..d766eb43 --- /dev/null +++ b/src/endpoints.sig @@ -0,0 +1,41 @@ +(* Copyright (c) 2010, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature ENDPOINTS = sig + + datatype method = GET | POST + val methodToString : method -> string + + type endpoint = {Method : method, Url : string} + val p_endpoint : endpoint Print.printer + + type report = {Endpoints : endpoint list} + val p_report : report Print.printer + + val summarize : Mono.file -> report + +end diff --git a/src/endpoints.sml b/src/endpoints.sml new file mode 100644 index 00000000..22186cbb --- /dev/null +++ b/src/endpoints.sml @@ -0,0 +1,78 @@ +(* Copyright (c) 2010, 2013, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Endpoints :> ENDPOINTS = struct + +open Print.PD +open Print + +open Mono + +datatype method = GET | POST + +fun methodToString GET = "GET" + | methodToString POST = "POST" + +type endpoint = {Method : method, Url : string} +type report = {Endpoints : endpoint list} + +fun p_endpoint {Method = m, Url = u} = + box [string "{", + string "\"method\": \"", string (methodToString m), string "\",", + string "\"url\": \"", string u, string "\"", + string "}"] + +fun p_report {Endpoints = el} = + box [string "{\"endpoints\":", + space, + string "[", + p_list_sep (box [string ",", newline]) p_endpoint el, + string "]}"] + +fun summarize file = + let + fun exportKindToMethod (Link _) = GET + | exportKindToMethod (Action _) = POST + | exportKindToMethod (Rpc _) = POST + | exportKindToMethod (Extern _) = POST + + fun decl ((d, _), st as endpoints) = + let + in + case d of + DExport (ek, id, i, tl, rt, f) => + {Method = exportKindToMethod ek, Url = id} :: st + | _ => st + end + + val (decls, _) = file + val ep = foldl decl [] decls + in + {Endpoints = ep} + end + +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 99005df5..56d98587 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -49,7 +49,7 @@ fun parse_flags flag_info args = | "--h" => "-help" | "--help" => "-help" | _ => arg - + fun loop [] : string list = [] | loop (arg :: args) = let @@ -114,6 +114,7 @@ fun oneRun args = val demo = ref (NONE : (string * bool) option) val tutorial = ref false val css = ref false + val endpoints = ref false val () = (Compiler.debug := false; Elaborate.verbose := false; @@ -162,12 +163,14 @@ fun oneRun args = SOME "print numeric version number and exit"), ("css", set_true css, SOME "print categories of CSS properties"), + ("endpoints", set_true endpoints, + SOME "print exposed URL endpoints"), ("print-ccompiler", ZERO printCCompiler, SOME "print C compiler and exit"), ("print-cinclude", ZERO printCInclude, SOME "print directory of C headers and exit"), ("ccompiler", ONE ("", Settings.setCCompiler), - SOME "set the C compiler to "), + SOME "set the C compiler to "), ("demo", ONE ("", fn prefix => demo := SOME (prefix, false)), NONE), @@ -268,8 +271,8 @@ fun oneRun args = " only one is allowed.\nSpecified projects: "^ String.concatWith ", " files) in - case (!css, !demo, !tutorial) of - (true, _, _) => + case (!css, !demo, !tutorial, !endpoints) of + (true, _, _, _) => (case Compiler.run Compiler.toCss job of NONE => OS.Process.failure | SOME {Overall = ov, Classes = cl} => @@ -282,13 +285,24 @@ fun oneRun args = app (print o Css.othersToString) ots; print "\n")) cl; OS.Process.success)) - | (_, SOME (prefix, guided), _) => + | (_, SOME (prefix, guided), _, _) => if Demo.make' {prefix = prefix, dirname = job, guided = guided} then OS.Process.success else OS.Process.failure - | (_, _, true) => (Tutorial.make job; - OS.Process.success) + | (_, _, true, _) => (Tutorial.make job; + OS.Process.success) + | (_, _, _, true) => + (case Compiler.run Compiler.toEndpoints job of + NONE => OS.Process.failure + | SOME es => + let + val r = Endpoints.p_report es + in + Print.eprint r; + print "\n"; + OS.Process.success + end) | _ => if !tc then (Compiler.check Compiler.toElaborate job; -- cgit v1.2.3 From ba1871b3b9cc669c43420f993719690b45326e2f Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Sat, 12 Jan 2019 16:20:14 +0200 Subject: Including app.js in output of endpoints --- src/cjr_print.sml | 6 ++++-- src/compiler.sig | 4 +++- src/compiler.sml | 29 +++++++++++++++++++++++++---- src/demo.sml | 4 ++++ src/endpoints.sig | 5 ++++- src/endpoints.sml | 25 ++++++++++++++++++++++++- src/main.mlton.sml | 24 ++++++------------------ src/settings.sig | 3 +++ src/settings.sml | 7 ++++++- 9 files changed, 79 insertions(+), 28 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 31653a74..5983b9e5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2550,8 +2550,10 @@ fun p_decl env (dAll as (d, loc) : decl) = (case Settings.getOutputJsFile () of NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js" | SOME s => s) - val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), - file = name} + val js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), + file = name} + val () = app_js := js + val () = Endpoints.setJavaScript js in box [string "static char jslib[] = \"", string (Prim.toCString s), diff --git a/src/compiler.sig b/src/compiler.sig index d4521b9f..6ed2f9a6 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -35,6 +35,7 @@ signature COMPILER = sig sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -116,6 +117,7 @@ signature COMPILER = sig val css : (Core.file, Css.report) phase val monoize : (Core.file, Mono.file) phase val mono_opt : (Mono.file, Mono.file) phase + val endpoints : (Mono.file, Mono.file) phase val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase @@ -171,7 +173,7 @@ signature COMPILER = sig val toEffectize : (string, Core.file) transform val toCss : (string, Css.report) transform val toMonoize : (string, Mono.file) transform - val toEndpoints : (string, Endpoints.report) transform + val toEndpoints : (string, Mono.file) transform val toMono_opt1 : (string, Mono.file) transform val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 4ef9ba19..7099effc 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -39,6 +39,7 @@ type job = { sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -275,7 +276,7 @@ val parseUr = { handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job ({prefix, database, exe, sql, sources, debug, profile, +fun p_job ({prefix, database, exe, sql, endpoints, sources, debug, profile, timeout, ffi, link, headers, scripts, clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let @@ -304,6 +305,10 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, NONE => string "No SQL file." | SOME sql => string ("SQL fle: " ^ sql), newline, + case endpoints of + NONE => string "No endpoints file." + | SOME ep => string ("Endpoints fle: " ^ ep), + newline, string "Timeout: ", string (Int.toString timeout), newline, @@ -443,6 +448,7 @@ fun parseUrp' accLibs fname = sources = [fname], exe = fname ^ ".exe", sql = NONE, + endpoints = NONE, debug = Settings.getDebug (), profile = false, timeout = 120, @@ -581,6 +587,7 @@ fun parseUrp' accLibs fname = val database = ref (Settings.getDbstring ()) val exe = ref (Settings.getExe ()) val sql = ref (Settings.getSql ()) + val endpoints = ref (Settings.getEndpoints ()) val debug = ref (Settings.getDebug ()) val profile = ref false val timeout = ref NONE @@ -622,6 +629,7 @@ fun parseUrp' accLibs fname = exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, ext = SOME "exe"}), sql = !sql, + endpoints = !endpoints, debug = !debug, profile = !profile, timeout = Option.getOpt (!timeout, 60), @@ -684,6 +692,7 @@ fun parseUrp' accLibs fname = database = mergeO (fn (old, _) => old) (#database old, #database new), exe = #exe old, sql = #sql old, + endpoints = #endpoints old, debug = #debug old orelse #debug new, profile = #profile old orelse #profile new, timeout = #timeout old, @@ -1430,13 +1439,13 @@ val mono_opt = { } val endpoints = { - func = Endpoints.summarize, - print = Endpoints.p_report + func = Endpoints.collect, + print = MonoPrint.p_file MonoEnv.empty } val toEndpoints = transform endpoints "endpoints" o toMonoize -val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize +val toMono_opt1 = transform mono_opt "mono_opt1" o toEndpoints val untangle = { func = Untangle.untangle, @@ -1726,6 +1735,18 @@ fun compile job = TextIO.closeOut outf end; + case #endpoints job of + NONE => () + | SOME endpoints => + let + val report = Endpoints.summarize () + val outf = TextIO.openOut endpoints + val s = TextIOPP.openOut {dst = outf, wid = 80} + in + Print.fprint s (Endpoints.p_report report); + TextIO.closeOut outf + end; + compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} diff --git a/src/demo.sml b/src/demo.sml index eaec38bb..ef57e65b 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -98,6 +98,10 @@ fun make' {prefix, dirname, guided} = NONE => OS.Path.joinDirFile {dir = dirname, file = "demo.sql"} | SOME s => s), + endpoints = SOME (case Settings.getEndpoints () of + NONE => OS.Path.joinDirFile {dir = dirname, + file = "demo-endpoints.json"} + | SOME e => e), debug = Settings.getDebug (), timeout = Int.max (#timeout combined, #timeout urp), profile = false, diff --git a/src/endpoints.sig b/src/endpoints.sig index f2c3c305..89e72add 100644 --- a/src/endpoints.sig +++ b/src/endpoints.sig @@ -36,6 +36,9 @@ signature ENDPOINTS = sig type report = {Endpoints : endpoint list} val p_report : report Print.printer - val summarize : Mono.file -> report + val reset : unit -> unit + val collect : Mono.file -> Mono.file + val setJavaScript : string -> unit + val summarize : unit -> report end diff --git a/src/endpoints.sml b/src/endpoints.sml index bb0b1d66..5699f319 100644 --- a/src/endpoints.sml +++ b/src/endpoints.sml @@ -59,7 +59,14 @@ fun p_report {Endpoints = el} = p_list_sep (box [string ",", newline]) p_endpoint el, string "]}"] -fun summarize file = +val endpoints = ref ([] : endpoint list) +val jsFile = ref (NONE : string option) + +fun setJavaScript x = jsFile := SOME x + +fun reset () = (endpoints := []; jsFile := NONE) + +fun collect file = let fun exportKindToMethod (Link _) = GET | exportKindToMethod (Action _) = POST @@ -75,6 +82,8 @@ fun summarize file = | _ => st end + val () = reset () + val (decls, _) = file val ep = foldl decl [] decls @@ -87,6 +96,20 @@ fun summarize file = {Method = GET, Url = f, LastModified = NONE, ContentType = SOME "text/javascript"} :: st val ep = foldl jsfile ep (Settings.listJsFiles ()) + in + endpoints := ep; + file + end + +fun summarize () = + let + val ep = !endpoints + val js = !jsFile + val ep = + case js of + NONE => ep + | SOME js => + {Method = GET, Url = js, LastModified = NONE, ContentType = SOME "text/javascript"} :: ep in {Endpoints = ep} end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 56d98587..bfa40265 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -114,7 +114,6 @@ fun oneRun args = val demo = ref (NONE : (string * bool) option) val tutorial = ref false val css = ref false - val endpoints = ref false val () = (Compiler.debug := false; Elaborate.verbose := false; @@ -163,8 +162,6 @@ fun oneRun args = SOME "print numeric version number and exit"), ("css", set_true css, SOME "print categories of CSS properties"), - ("endpoints", set_true endpoints, - SOME "print exposed URL endpoints"), ("print-ccompiler", ZERO printCCompiler, SOME "print C compiler and exit"), ("print-cinclude", ZERO printCInclude, @@ -220,6 +217,8 @@ fun oneRun args = SOME "serve JavaScript as "), ("sql", ONE ("", Settings.setSql o SOME), SOME "output sql script as "), + ("endpoints", ONE ("", Settings.setEndpoints o SOME), + SOME "output exposed URL endpoints in JSON as "), ("static", call_true Settings.setStaticLinking, SOME "enable static linking"), ("stop", ONE ("", Compiler.setStop), @@ -271,8 +270,8 @@ fun oneRun args = " only one is allowed.\nSpecified projects: "^ String.concatWith ", " files) in - case (!css, !demo, !tutorial, !endpoints) of - (true, _, _, _) => + case (!css, !demo, !tutorial) of + (true, _, _) => (case Compiler.run Compiler.toCss job of NONE => OS.Process.failure | SOME {Overall = ov, Classes = cl} => @@ -285,24 +284,13 @@ fun oneRun args = app (print o Css.othersToString) ots; print "\n")) cl; OS.Process.success)) - | (_, SOME (prefix, guided), _, _) => + | (_, SOME (prefix, guided), _) => if Demo.make' {prefix = prefix, dirname = job, guided = guided} then OS.Process.success else OS.Process.failure - | (_, _, true, _) => (Tutorial.make job; + | (_, _, true) => (Tutorial.make job; OS.Process.success) - | (_, _, _, true) => - (case Compiler.run Compiler.toEndpoints job of - NONE => OS.Process.failure - | SOME es => - let - val r = Endpoints.p_report es - in - Print.eprint r; - print "\n"; - OS.Process.success - end) | _ => if !tc then (Compiler.check Compiler.toElaborate job; diff --git a/src/settings.sig b/src/settings.sig index a6a9c5fc..97d56b45 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -240,6 +240,9 @@ signature SETTINGS = sig val setSql : string option -> unit val getSql : unit -> string option + val setEndpoints : string option -> unit + val getEndpoints : unit -> string option + val setCoreInline : int -> unit val getCoreInline : unit -> int diff --git a/src/settings.sml b/src/settings.sml index f42df135..0e999587 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -703,6 +703,10 @@ val sql = ref (NONE : string option) fun setSql so = sql := so fun getSql () = !sql +val endpoints = ref (NONE : string option) +fun setEndpoints so = endpoints := so +fun getEndpoints () = !endpoints + val coreInline = ref 5 fun setCoreInline n = coreInline := n fun getCoreInline () = !coreInline @@ -729,7 +733,7 @@ fun getSigFile () = !sigFile val fileCache = ref (NONE : string option) fun setFileCache v = - (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true + (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true | SOME _ => false) then ErrorMsg.error "The selected database engine is incompatible with file caching." else @@ -1007,6 +1011,7 @@ fun reset () = dbstring := NONE; exe := NONE; sql := NONE; + endpoints := NONE; coreInline := 5; monoInline := 5; staticLinking := false; -- cgit v1.2.3 From 18d42a0f0829132803a8c508e1d1cc797c6dbbde Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Mar 2019 14:57:25 -0400 Subject: Allow dollar-sign shortcuts for 'file' and 'jsFile' directives --- src/compiler.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index 7099effc..aad5ce8c 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -953,7 +953,7 @@ fun parseUrp' accLibs fname = uri :: fname :: rest => (Settings.setFilePath thisPath; Settings.addFile {Uri = uri, - LoadFromFilename = fname, + LoadFromFilename = pathify fname, MimeType = case rest of [] => NONE | [ty] => SOME ty @@ -964,7 +964,7 @@ fun parseUrp' accLibs fname = | "jsFile" => (Settings.setFilePath thisPath; - Settings.addJsFile arg) + Settings.addJsFile (pathify arg)) | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () -- cgit v1.2.3 From 8e561ed471518c426c59f210f5ea07d4f178cbe5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 30 Mar 2019 17:42:13 -0400 Subject: Ensure compilation fails even if the only problem is a missing source file --- src/compiler.sml | 1 + 1 file changed, 1 insertion(+) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index aad5ce8c..0aba3a40 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1200,6 +1200,7 @@ val parse = { else (); ErrorMsg.error ("Missing source file: " ^ fname); + anyErrors := true; (Source.DSequence "", ErrorMsg.dummySpan)) val dsFfi = map parseFfi ffi -- cgit v1.2.3 From d7e10798f1905161e5790444e604f439281d4220 Mon Sep 17 00:00:00 2001 From: Oisín Mac Fhearaí Date: Sun, 11 Aug 2019 05:04:43 +0100 Subject: * When htmlifying characters, don't use numeric escapes if they're printable -- instead, try to convert them to UTF-8. * Add libicuio to linked C libraries --- src/c/Makefile.am | 2 +- src/c/urweb.c | 19 ++++++++++++++++--- src/compiler.sml | 8 ++++++-- 3 files changed, 23 insertions(+), 6 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/c/Makefile.am b/src/c/Makefile.am index 95582793..ff4b6eaf 100644 --- a/src/c/Makefile.am +++ b/src/c/Makefile.am @@ -11,7 +11,7 @@ AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecate liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \ -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' \ -version-info 1:0:0 -liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata +liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata -licuio liburweb_http_la_LIBADD = liburweb.la liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ -version-info 1:0:0 diff --git a/src/c/urweb.c b/src/c/urweb.c index b820354f..dad15568 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -20,7 +20,6 @@ #include -#include #include #include "types.h" @@ -2347,7 +2346,21 @@ uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { int len; uw_check(ctx, INTS_MAX+3); - len = sprintf(ctx->page.front, "&#%u;", n); + + if(uw_Basis_isprint(ctx, ch)) { + + UChar32 ins[1] = { ch }; + char buf[5]; + int32_t len_written = 0; + UErrorCode err = U_ZERO_ERROR; + + u_strToUTF8(buf, 5, &len_written, ins, 1, &err); + sprintf(ctx->page.front, "%s", buf); + // printf("buf: %s, hex: %x, len_written: %d, err: %s\n", buf, ch, len_written, u_errorName(err)); + len = len_written; + } else { + len = sprintf(ctx->page.front, "&#%u;", n); + } ctx->page.front += len; return uw_unit_v; @@ -2459,7 +2472,7 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { else { uw_Basis_htmlifySpecialChar_w(ctx, c1); } - } + } return uw_unit_v; } diff --git a/src/compiler.sml b/src/compiler.sml index 0aba3a40..c00fe807 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1610,9 +1610,13 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ + !Settings.configLib ^ "/liburweb.a " ^ + !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic + proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ + !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" -- cgit v1.2.3 From 39cf1b0633fd95ff82815741c9c3d35a0f762cf2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 14 Sep 2019 13:14:55 -0400 Subject: More detailed error message for bad path kind spec (closes #178) --- src/compiler.sml | 2 +- tests/badkind.ur | 1 + tests/badkind.urp | 3 +++ 3 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 tests/badkind.ur create mode 100644 tests/badkind.urp (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index c00fe807..fab939f9 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -745,7 +745,7 @@ fun parseUrp' accLibs fname = | "relation" => Settings.Relation | "cookie" => Settings.Cookie | "style" => Settings.Style - | _ => (ErrorMsg.error "Bad path kind spec"; + | _ => (ErrorMsg.error ("Bad path kind spec \"" ^ s ^ "\""); Settings.Any) fun parsePattern s = diff --git a/tests/badkind.ur b/tests/badkind.ur new file mode 100644 index 00000000..600f7a35 --- /dev/null +++ b/tests/badkind.ur @@ -0,0 +1 @@ +fun main () : transaction page = ahoy! diff --git a/tests/badkind.urp b/tests/badkind.urp new file mode 100644 index 00000000..934e4928 --- /dev/null +++ b/tests/badkind.urp @@ -0,0 +1,3 @@ +rewrite Badkind/main / + +badkind -- cgit v1.2.3 From 25b0685cefe772c73562665a4cc8d2d40e5ff600 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 13:58:01 +0100 Subject: Use elabFile completely instead of rebuilding it partially --- src/compiler.sml | 2 +- src/elaborate.sig | 5 +++- src/elaborate.sml | 4 ++- src/lsp.sml | 73 ++++++++++++++++++++++++++----------------------------- 4 files changed, 42 insertions(+), 42 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index fab939f9..ab7b86b4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1283,7 +1283,7 @@ val elaborate = { in Elaborate.elabFile basis (OS.FileSys.modTime basisF) topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) - ElabEnv.empty file + ElabEnv.empty (fn env => env) file end, print = ElabPrint.p_file ElabEnv.empty } diff --git a/src/elaborate.sig b/src/elaborate.sig index 88ea068f..d6747241 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -29,7 +29,10 @@ signature ELABORATE = sig val elabFile : Source.sgn_item list -> Time.time -> Source.decl list -> Source.sgn_item list -> Time.time - -> ElabEnv.env -> Source.file -> Elab.file + -> ElabEnv.env + -> (ElabEnv.env -> ElabEnv.env) (* Adapt env after stdlib but before elaborate *) + -> Source.file + -> Elab.file val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option diff --git a/src/elaborate.sml b/src/elaborate.sml index d5e190fa..85234775 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4760,7 +4760,7 @@ and elabStr (env, denv) (str, loc) = fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env -fun elabFile basis basis_tm topStr topSgn top_tm env file = +fun elabFile basis basis_tm topStr topSgn top_tm env changeEnv file = let val () = ModDb.snapshot () val () = ErrorMsg.resetStructureTracker () @@ -4857,6 +4857,8 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + val env' = changeEnv env' + fun elabDecl' x = (resetKunif (); resetCunif (); diff --git a/src/lsp.sml b/src/lsp.sml index 34209231..b5a92683 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,9 +417,7 @@ end structure SM = BinaryMapFn(SK) type fileState = - { envOfPreviousModules : ElabEnv.env - , decls : Elab.decl list - } + { decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -498,6 +496,8 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls then () else raise Fail ("Can only handle .ur files for now") val () = Elaborate.unifyMore := true + (* To reuse Basis and Top *) + val () = Elaborate.incremental := true (* Parsing .urp *) val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of NONE => raise LspError (InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) @@ -531,28 +531,35 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls } end) modulesBeforeThisFile - (* Parsing Basis and Top .urs *) + (* Parsing Basis and Top *) + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + val parsedBasisUrs = - case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs") of - NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ (Settings.libFile "basis.urs"))) + case C.run (C.transform C.parseUrs "parseUrs") basisF of + NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) | SOME a => a val parsedTopUrs = - case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs") of - NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ (Settings.libFile "top.urs"))) + case C.run (C.transform C.parseUrs "parseUrs") topF of + NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) | SOME a => a - (* Building env with previous .urs files *) - val envWithStdLib = - addSgnToEnv - (addSgnToEnv ElabEnv.empty parsedBasisUrs (Settings.libFile "basis.urs") true) - parsedTopUrs (Settings.libFile "top.urs") true - val envBeforeThisFile = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envWithStdLib parsedUrss + val parsedTopUr = + case C.run (C.transform C.parseUr "parseUr") topF' of + NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + | SOME a => a + (* Parsing .ur and .urs of current file *) - val (parsedUrs: (Source.sgn_item list) option) = + val (parsedUrs: Source.sgn option) = (if OS.FileSys.access (fileName ^ "s", []) then case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of NONE => NONE - | SOME a => SOME a + | SOME a => SOME ( Source.SgnConst a + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) else NONE) handle ex => NONE val () = ErrorMsg.resetErrors () @@ -562,34 +569,22 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls case parsedUrO of NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) | SOME parsedUr => - (* .ur file found -> typecheck *) + (* Parsing of .ur succeeded *) let - val (str, sgn', gs) = - Elaborate.elabStr - (envBeforeThisFile, Disjoint.empty) - (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - val () = - (* .urs file found -> check and compare with .ur file *) - (case parsedUrs of - NONE => () - | SOME parsedUrs => - let - val (sgn, gs) = Elaborate.elabSgn - (envBeforeThisFile, Disjoint.empty) - ( Source.SgnConst parsedUrs - , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}); - in - Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn - end) + val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val res = Elaborate.elabFile + parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty + (* Adding urs's of previous modules to env *) + (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) + , loc )] (* report back errors (as Diagnostics) *) val errors = ErrorMsg.readErrorLog () - val decls = case str of - (Elab.StrConst decls, _) => decls + val decls = case List.last res of + (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { envOfPreviousModules = envBeforeThisFile - , decls = decls - }, + (SOME { decls = decls }, List.map errorToDiagnostic errors) end end -- cgit v1.2.3 From f48703bf1b39c94c941ba101c3d2fd56a78d8289 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 16 Dec 2019 13:47:11 -0500 Subject: Support endpoints generation for urpless invocations (closes #187) --- src/compiler.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index fab939f9..06abed0c 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -448,7 +448,7 @@ fun parseUrp' accLibs fname = sources = [fname], exe = fname ^ ".exe", sql = NONE, - endpoints = NONE, + endpoints = Settings.getEndpoints (), debug = Settings.getDebug (), profile = false, timeout = 120, -- cgit v1.2.3