Mercurial > urweb
changeset 1848:e15234fbb163
Basis.tryRpc
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Tue, 16 Apr 2013 10:55:48 -0400 |
| parents | 8958b580d026 |
| children | 3005c66b70e8 |
| files | doc/manual.tex lib/js/urweb.js lib/ur/basis.urs src/core.sml src/core_print.sml src/core_untangle.sml src/core_util.sml src/css.sml src/effectize.sml src/especialize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/reduce.sml src/reduce_local.sml src/rpcify.sml src/settings.sig src/shake.sml tests/tryRpc.ur |
| diffstat | 22 files changed, 179 insertions(+), 74 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/manual.tex Mon Apr 01 10:13:49 2013 -0400 +++ b/doc/manual.tex Tue Apr 16 10:55:48 2013 -0400 @@ -2157,6 +2157,12 @@ \mt{val} \; \mt{rpc} : \mt{t} ::: \mt{Type} \to \mt{transaction} \; \mt{t} \to \mt{transaction} \; \mt{t} \end{array}$$ +There is an alternate form that uses $\mt{None}$ to indicate that an error occurred during RPC processing, rather than raising an exception to abort this branch of control flow. + +$$\begin{array}{l} + \mt{val} \; \mt{tryRpc} : \mt{t} ::: \mt{Type} \to \mt{transaction} \; \mt{t} \to \mt{transaction} \; (\mt{option} \; \mt{t}) +\end{array}$$ + \subsubsection{Asynchronous Message-Passing} To support asynchronous, ``server push'' delivery of messages to clients, any client that might need to receive an asynchronous message is assigned a unique ID. These IDs may be retrieved both on the client and on the server, during execution of code related to a client.
--- a/lib/js/urweb.js Mon Apr 01 10:13:49 2013 -0400 +++ b/lib/js/urweb.js Tue Apr 16 10:55:48 2013 -0400 @@ -1365,7 +1365,14 @@ window.location = s; } -function rc(prefix, uri, parse, k, needsSig) { +function makeSome(isN, v) { + if (isN) + return {v: v}; + else + return v; +} + +function rc(prefix, uri, parse, k, needsSig, isN) { if (!maySuspend) er("May not 'rpc' in main thread of 'code' for <active>"); @@ -1384,18 +1391,30 @@ if (isok) { var lines = xhr.responseText.split("\n"); - if (lines.length != 2) - whine("Bad RPC response lines"); + if (lines.length != 2) { + if (isN == null) + whine("Bad RPC response lines"); + else + k(null); + } else { + eval(lines[0]); - eval(lines[0]); - - try { - k(parse(lines[1])); - } catch (v) { - doExn(v); + try { + var v = parse(lines[1]); + try { + k(makeSome(isN, v)); + } catch (v) { + doExn(v); + } + } catch (v) { + k(null); + } } } else { - conn(); + if (isN == null) + conn(); + else + k(null); } xhrFinished(xhr);
--- a/lib/ur/basis.urs Mon Apr 01 10:13:49 2013 -0400 +++ b/lib/ur/basis.urs Tue Apr 16 10:55:48 2013 -0400 @@ -206,6 +206,8 @@ val sleep : int -> transaction unit val rpc : t ::: Type -> transaction t -> transaction t +val tryRpc : t ::: Type -> transaction t -> transaction (option t) +(* Returns [None] on error condition. *) (** Channels *)
--- a/src/core.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/core.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -86,6 +86,8 @@ withtype pat = pat' located +datatype failure_mode = datatype Settings.failure_mode + datatype exp' = EPrim of Prim.t | ERel of int @@ -115,7 +117,7 @@ | ELet of string * con * exp * exp - | EServerCall of int * exp list * con + | EServerCall of int * exp list * con * failure_mode withtype exp = exp' located
--- a/src/core_print.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/core_print.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -446,12 +446,12 @@ newline, p_exp (E.pushERel env x t) e2] - | EServerCall (n, es, _) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")"] + | EServerCall (n, es, _, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")"] | EKAbs (x, e) => box [string x, space,
--- a/src/core_untangle.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/core_untangle.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -48,7 +48,7 @@ case e of ENamed n => try n | EClosure (n, _) => try n - | EServerCall (n, _, _) => try n + | EServerCall (n, _, _, _) => try n | _ => s end
--- a/src/core_util.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/core_util.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -439,6 +439,14 @@ join (String.compare (x1, x2), fn () => pCompare (p1, p2))) (xps1, xps2) +fun fmCompare (fm1, fm2) = + case (fm1, fm2) of + (None, None) => EQUAL + | (None, _) => LESS + | (_, None) => GREATER + + | (Error, Error) => EQUAL + fun compare ((e1, _), (e2, _)) = case (e1, e2) of (EPrim p1, EPrim p2) => Prim.compare (p1, p2) @@ -547,9 +555,10 @@ | (ELet _, _) => LESS | (_, ELet _) => GREATER - | (EServerCall (n1, es1, _), EServerCall (n2, es2, _)) => + | (EServerCall (n1, es1, _, fm1), EServerCall (n2, es2, _, fm2)) => join (Int.compare (n1, n2), - fn () => joinL compare (es1, es2)) + fn () => join (fmCompare (fm1, fm2), + fn () => joinL compare (es1, es2))) | (EServerCall _, _) => LESS | (_, EServerCall _) => GREATER @@ -738,12 +747,12 @@ fn e2' => (ELet (x, t', e1', e2'), loc)))) - | EServerCall (n, es, t) => + | EServerCall (n, es, t, fm) => S.bind2 (ListUtil.mapfold (mfe ctx) es, fn es' => S.map2 (mfc ctx t, fn t' => - (EServerCall (n, es', t'), loc))) + (EServerCall (n, es', t', fm), loc))) | EKAbs (x, e) => S.map2 (mfe (bind (ctx, RelK x)) e,
--- a/src/css.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/css.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2010, Adam Chlipala +(* Copyright (c) 2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -260,7 +260,7 @@ in (merge' (sm1, sm2), classes) end - | EServerCall (_, es, _) => expList (es, classes) + | EServerCall (_, es, _, _) => expList (es, classes) and expList (es, classes) = foldl (fn (e, (sm, classes)) => let
--- a/src/effectize.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/effectize.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2009-2010, Adam Chlipala +(* Copyright (c) 2009-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -46,7 +46,7 @@ EFfi f => effectful f | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, @@ -69,7 +69,7 @@ fun exp writers readers pushers e = case e of ENamed n => IM.inDomain (pushers, n) - | EServerCall (n, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) + | EServerCall (n, _, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) | _ => false fun couldWriteWithRpc writers readers pushers = U.Exp.exists {kind = fn _ => false, @@ -80,7 +80,7 @@ case e of EFfi ("Basis", "getCookie") => true | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
--- a/src/especialize.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/especialize.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -205,7 +205,7 @@ | EWrite e1 => ca depth e1 | EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es | ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2) - | EServerCall (_, es, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es + | EServerCall (_, es, _, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es fun enterAbs depth e = case #1 e of @@ -348,11 +348,11 @@ in ((ELet (x, t, e1, e2), loc), st) end - | EServerCall (n, es, t) => + | EServerCall (n, es, t, fm) => let val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es in - ((EServerCall (n, es, t), loc), st) + ((EServerCall (n, es, t, fm), loc), st) end in case getApp e of
--- a/src/jscomp.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/jscomp.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -930,10 +930,21 @@ st) end - | EServerCall (e, t, eff) => + | EServerCall (e, t, eff, fm) => let val (e, st) = jsE inner (e, st) val (unurl, st) = unurlifyExp loc (t, st) + val lastArg = case fm of + None => "null" + | Error => + let + val isN = if isNullable t then + "true" + else + "false" + in + "cons({c:\"c\",v:" ^ isN ^ "},null)" + end in (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\"" ^ Settings.getUrlPrefix () @@ -944,7 +955,7 @@ ^ (case eff of ReadCookieWrite => "true" | _ => "false") - ^ "},null)))))}")], + ^ "}," ^ lastArg ^ ")))))}")], st) end @@ -1231,11 +1242,11 @@ ((ESignalSource e, loc), st) end - | EServerCall (e1, t, ef) => + | EServerCall (e1, t, ef, fm) => let val (e1, st) = exp outer (e1, st) in - ((EServerCall (e1, t, ef), loc), st) + ((EServerCall (e1, t, ef, fm), loc), st) end | ERecv (e1, t) => let
--- a/src/mono.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/mono.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -120,7 +120,7 @@ | ESignalBind of exp * exp | ESignalSource of exp - | EServerCall of exp * typ * effect + | EServerCall of exp * typ * effect * failure_mode | ERecv of exp * typ | ESleep of exp | ESpawn of exp
--- a/src/mono_print.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/mono_print.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -357,7 +357,7 @@ p_exp env e, string ")"] - | EServerCall (n, _, _) => box [string "Server(", + | EServerCall (n, _, _, _) => box [string "Server(", p_exp env n, string ")"] | ERecv (n, _) => box [string "Recv(",
--- a/src/mono_reduce.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/mono_reduce.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -515,7 +515,7 @@ | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e - | EServerCall (e, _, _) => summarize d e @ [Unsure] + | EServerCall (e, _, _, _) => summarize d e @ [Unsure] | ERecv (e, _) => summarize d e @ [Unsure] | ESleep e => summarize d e @ [Unsure] | ESpawn e => summarize d e @ [Unsure]
--- a/src/mono_util.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/mono_util.sml Tue Apr 16 10:55:48 2013 -0400 @@ -380,12 +380,12 @@ fn e' => (ESignalSource e', loc)) - | EServerCall (s, t, eff) => + | EServerCall (s, t, eff, fm) => S.bind2 (mfe ctx s, fn s' => S.map2 (mft t, fn t' => - (EServerCall (s', t', eff), loc))) + (EServerCall (s', t', eff, fm), loc))) | ERecv (s, t) => S.bind2 (mfe ctx s, fn s' => @@ -510,7 +510,7 @@ | ESignalReturn e1 => appl e1 | ESignalBind (e1, e2) => (appl e1; appl e2) | ESignalSource e1 => appl e1 - | EServerCall (e1, _, _) => appl e1 + | EServerCall (e1, _, _, _) => appl e1 | ERecv (e1, _) => appl e1 | ESleep e1 => appl e1 | ESpawn e1 => appl e1)
--- a/src/monoize.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/monoize.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -4188,7 +4188,7 @@ ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall (n, es, t) => + | L.EServerCall (n, es, t, fmode) => let val t = monoType env t val (_, ft, _, name) = Env.lookupENamed env n @@ -4218,7 +4218,7 @@ else L'.ReadOnly - val e = (L'.EServerCall (call, t, eff), loc) + val e = (L'.EServerCall (call, t, eff, fmode), loc) val e = liftExpInExp 0 e val e = (L'.EAbs ("_", unit, unit, e), loc) in
--- a/src/reduce.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/reduce.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -804,7 +804,7 @@ (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) end - | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) in (*if dangling (edepth' (deKnown env)) r then (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
--- a/src/reduce_local.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/reduce_local.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -353,7 +353,7 @@ | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) fun reduce file = let
--- a/src/rpcify.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/rpcify.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2009, 2012, Adam Chlipala +(* Copyright (c) 2009, 2012-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -42,15 +42,22 @@ fun frob file = let - val rpcBaseIds = foldl (fn ((d, _), rpcIds) => - case d of - DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n) - | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then - IS.add (rpcIds, n) - else - rpcIds - | _ => rpcIds) - IS.empty file + val (rpcBaseIds, trpcBaseIds) = + foldl (fn ((d, _), (rpcIds, trpcIds)) => + case d of + DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => + (IS.add (rpcIds, n), trpcIds) + | DVal (_, n, _, (EFfi ("Basis", "tryRpc"), _), _) => + (rpcIds, IS.add (trpcIds, n)) + | DVal (_, n, _, (ENamed n', _), _) => + if IS.member (rpcIds, n') then + (IS.add (rpcIds, n), trpcIds) + else if IS.member (trpcIds, n') then + (rpcIds, IS.add (trpcIds, n)) + else + (rpcIds, trpcIds) + | _ => (rpcIds, trpcIds)) + (IS.empty, IS.empty) file val tfuncs = foldl (fn ((d, _), tfuncs) => @@ -89,7 +96,7 @@ | EApp (e1, e2) => getApp (#1 e1, e2 :: args) | _ => NONE - fun newRpc (trans : exp, st : state) = + fun newRpc (trans : exp, st : state, fm) = case getApp (#1 trans, []) of NONE => (ErrorMsg.errorAt (#2 trans) "RPC code doesn't use a named function or transaction"; @@ -114,16 +121,19 @@ val st = {exported = exported, export_decls = export_decls} - val e' = EServerCall (n, args, ran) + val e' = EServerCall (n, args, ran, fm) in (e', st) end in case e of - EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st) + EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st, None) + | EApp ((ECApp ((EFfi ("Basis", "tryRpc"), _), ran), _), trans) => newRpc (trans, st, Error) | EApp ((ECApp ((ENamed n, _), ran), _), trans) => if IS.member (rpcBaseIds, n) then - newRpc (trans, st) + newRpc (trans, st, None) + else if IS.member (trpcBaseIds, n) then + newRpc (trans, st, Error) else (e, st)
--- a/src/settings.sig Mon Apr 01 10:13:49 2013 -0400 +++ b/src/settings.sig Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without
--- a/src/shake.sml Mon Apr 01 10:13:49 2013 -0400 +++ b/src/shake.sml Tue Apr 16 10:55:48 2013 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -186,7 +186,7 @@ in case e of ENamed n => check n - | EServerCall (n, _, _) => check n + | EServerCall (n, _, _, _) => check n | _ => s end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/tryRpc.ur Tue Apr 16 10:55:48 2013 -0400 @@ -0,0 +1,46 @@ +fun isBeppo (s : string) : transaction string = + case s of + "Beppo" => return "Yup, that's him!" + | "Mephisto" => error <xml>Great googely moogely!</xml> + | _ => return "Who's that?" + +fun listOf (n : int) = + if n < 0 then + error <xml>Negative!</xml> + else if n = 0 then + return [] + else + ls <- listOf (n - 1); + return (n :: ls) + +fun length ls = + case ls of + [] => 0 + | _ :: ls' => 1 + length ls' + +fun main () : transaction page = + s <- source ""; + ns <- source ""; + return <xml><body> + <ctextbox source={s}/> + <button value="rpc" onclick={fn _ => v <- get s; + r <- rpc (isBeppo v); + alert r}/> + <button value="tryRpc" onclick={fn _ => v <- get s; + r <- tryRpc (isBeppo v); + case r of + None => alert "Faaaaaailure." + | Some r => alert ("Success: " ^ r)}/> + + <hr/> + + <ctextbox source={ns}/> + <button value="rpc" onclick={fn _ => v <- get ns; + r <- rpc (listOf (readError v)); + alert (show (length r))}/> + <button value="tryRpc" onclick={fn _ => v <- get ns; + r <- tryRpc (listOf (readError v)); + case r of + None => alert "Faaaaaailure." + | Some r => alert ("Success: " ^ show (length r))}/> + </body></xml>