diff --git a/core/dune b/core/dune index 6d06059fc..4ad604cb4 100644 --- a/core/dune +++ b/core/dune @@ -18,7 +18,8 @@ conduit-lwt-unix uri websocket websocket-lwt-unix.cohttp findlib menhirLib links.lens calendar - dynlink) + dynlink + rdf rdf_lwt iri) (preprocess (pps ppx_deriving.std ppx_deriving_yojson))) diff --git a/core/evalir.ml b/core/evalir.ml index 0b20d45eb..4fec8d4b0 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -515,9 +515,11 @@ struct apply_cont cont env (`Record []) (*****************) | `PrimitiveFunction (n,None), args -> - apply_cont cont env (Lib.apply_pfun n args (Value.Env.request_data env)) + Lib.apply_pfun n args (Value.Env.request_data env) >>= fun v -> + apply_cont cont env v | `PrimitiveFunction (_, Some code), args -> - apply_cont cont env (Lib.apply_pfun_by_code code args (Value.Env.request_data env)) + Lib.apply_pfun_by_code code args (Value.Env.request_data env) >>= fun v -> + apply_cont cont env v | `ClientFunction name, args -> let req_data = Value.Env.request_data env in client_call req_data name cont args diff --git a/core/lib.ml b/core/lib.ml index a0801ba6b..f5b6e2e44 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -2,6 +2,7 @@ open CommonTypes open Utility open Proc +open Lwt (* Error functions *) let runtime_error msg = raise (Errors.runtime_error msg) @@ -32,14 +33,16 @@ let datatype = DesugarDatatypes.read ~aliases:alias_env type primitive = [ Value.t -| `PFun of RequestData.request_data -> Value.t list -> Value.t ] +| `PFun of RequestData.request_data -> Value.t list -> Value.t Lwt.t ] type pure = PURE | IMPURE type located_primitive = [ `Client | `Server of primitive | primitive ] +let pure_pfun fn = `PFun(fun _ xs -> Lwt.return (fn xs)) + let mk_binop_fn impl unbox_fn constr = function - | [x; y] -> constr (impl (unbox_fn x) (unbox_fn y)) + | [x; y] -> Lwt.return (constr (impl (unbox_fn x) (unbox_fn y))) | _ -> raise (internal_error "arity error in integer operation") let int_op impl pure : located_primitive * Types.datatype * pure = @@ -63,7 +66,7 @@ let conversion_op' ~unbox ~conv ~(box :'a->Value.t): Value.t list -> Value.t = f let conversion_op ~from ~unbox ~conv ~(box :'a->Value.t) ~into pure : located_primitive * Types.datatype * pure = let open Types in - ((`PFun (fun _ x -> conversion_op' ~unbox:unbox ~conv:conv ~box:box x) : located_primitive), + ((pure_pfun (fun x -> conversion_op' ~unbox ~conv:conv ~box:box x) : located_primitive), (let q, r = fresh_row_quantifier (lin_any, res_any) in (ForAll ([q], Function (make_tuple_type [from], r, into)) : datatype)), pure) @@ -74,7 +77,7 @@ let string_to_xml : Value.t -> Value.t = function (* The following functions expect 1 argument. Assert false otherwise. *) let float_fn fn pure = - (`PFun (fun _ args -> + (pure_pfun (fun args -> match args with | [c] -> (Value.box_float (fn (Value.unbox_float c))) | _ -> assert false), @@ -101,9 +104,10 @@ let p3D fn = | [a;b;c] -> fn a b c req_data | _ -> assert false) -let p1 fn = p1D (fun x _ -> fn x) -let p2 fn = p2D (fun x y _ -> fn x y) -let p3 fn = p3D (fun x y z _ -> fn x y z) +let p1 fn = p1D (fun x _ -> Lwt.return (fn x)) +let p2 fn = p2D (fun x y _ -> Lwt.return (fn x y)) +let p3 fn = p3D (fun x y z _ -> Lwt.return (fn x y z)) + let rec equal l r = match l, r with @@ -333,14 +337,12 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ PURE); "intToXml", - (`PFun (fun _ -> - string_to_xml -<- (conversion_op' ~unbox:Value.unbox_int ~conv:(string_of_int) ~box:Value.box_string)), + (pure_pfun (string_to_xml -<- (conversion_op' ~unbox:Value.unbox_int ~conv:(string_of_int) ~box:Value.box_string)), datatype "(Int) -> Xml", PURE); "floatToXml", - (`PFun (fun _ -> - string_to_xml -<- (conversion_op' ~unbox:Value.unbox_float ~conv:(string_of_float') ~box:Value.box_string)), + (pure_pfun (string_to_xml -<- (conversion_op' ~unbox:Value.unbox_float ~conv:(string_of_float') ~box:Value.box_string)), datatype "(Float) -> Xml", PURE); @@ -380,12 +382,12 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ IMPURE); "self", - (`PFun (fun _ _ -> `Pid (`ServerPid (Proc.get_current_pid()))), + (pure_pfun (fun _ -> `Pid (`ServerPid (Proc.get_current_pid()))), datatype "() {hear{a}|e}~> Process ({ hear{a} })", IMPURE); "here", - (`PFun (fun _ _ -> `SpawnLocation (`ServerSpawnLoc)), + (pure_pfun (fun _ -> `SpawnLocation (`ServerSpawnLoc)), datatype "() ~> Location", IMPURE ); @@ -393,13 +395,13 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ "there", (`PFun (fun req_data _ -> let client_id = RequestData.get_client_id req_data in - `SpawnLocation (`ClientSpawnLoc client_id)), + Lwt.return (`SpawnLocation (`ClientSpawnLoc client_id))), datatype "() ~> Location", IMPURE ); "haveMail", - (`PFun(fun _ -> + (`PFun(fun _ _ -> runtime_error "The haveMail function is not implemented on the server yet"), datatype "() {:_|_}~> Bool", IMPURE); @@ -1055,7 +1057,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ let resp_headers = RequestData.get_http_response_headers req_data in RequestData.set_http_response_headers req_data (("Set-Cookie", cookieName ^ "=" ^ cookieVal) :: resp_headers); - `Record [] + Lwt.return (`Record []) (* Note: perhaps this should affect cookies returned by getcookie during the current request. *)), datatype "(String, String) ~> ()", @@ -1084,7 +1086,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ else "" in - Value.box_string value), + Lwt.return (Value.box_string value)), datatype "(String) ~> String", IMPURE); @@ -1095,7 +1097,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ let resp_headers = RequestData.get_http_response_headers req_data in RequestData.set_http_response_headers req_data (("Location", url) :: resp_headers); RequestData.set_http_response_code req_data 302; - `Record [] + Lwt.return (`Record []) ), datatype "(String) ~> ()", IMPURE); (* Should this function really return? @@ -1125,32 +1127,32 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ "serverTime", (`Server - (`PFun (fun _ _ -> + (pure_pfun (fun _ -> Value.box_int(int_of_float(Unix.time())))), datatype "() ~> Int", IMPURE); "lensQueryTimeMilliseconds", (`Server - (`PFun (fun _ _ -> Value.box_int (Lens.Statistics.get_query_time ()))), + (pure_pfun (fun _ -> Value.box_int (Lens.Statistics.get_query_time ()))), datatype "() ~> Int", IMPURE); "lensQueryCount", (`Server - (`PFun (fun _ _ -> Value.box_int (Lens.Statistics.get_query_count ()))), + (pure_pfun (fun _ -> Value.box_int (Lens.Statistics.get_query_count ()))), datatype "() ~> Int", IMPURE); "lensQueryStatisticsReset", (`Server - (`PFun (fun _ _ -> Value.box_unit (Lens.Statistics.reset ()))), + (pure_pfun (fun _ -> Value.box_unit (Lens.Statistics.reset ()))), datatype "() ~> ()", IMPURE); "serverTimeMilliseconds", (`Server - (`PFun (fun _ _ -> + (pure_pfun (fun _ -> Value.box_int(time_milliseconds()))), datatype "() ~> Int", IMPURE); @@ -1223,14 +1225,14 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ IMPURE); "now", - (`PFun (fun _ _ -> Value.box_datetime (Timestamp.now ())), + (pure_pfun (fun _ -> Value.box_datetime (Timestamp.now ())), datatype "() -> DateTime", IMPURE); (* Returns UTC offset of local time. For example, if local time is British Summer Time, then utcOffset() would return 1. *) "utcOffset", - (`PFun (fun _ _ -> + (pure_pfun (fun _ -> CalendarLib.Time_Zone.(gap UTC Local) |> Value.box_int), datatype "() ~> Int", @@ -1326,8 +1328,8 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ IMPURE); "getDatabaseConfig", - (`PFun - (fun _ _ -> + (pure_pfun + (fun _ -> let args = from_option "" (Settings.get Database.connection_info) in match Settings.get DatabaseDriver.driver with | None -> @@ -1365,7 +1367,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ let cgi_params = RequestData.get_cgi_parameters req_data in let makestrpair (x1, x2) = `Record [("1", Value.box_string x1); ("2", Value.box_string x2)] in let is_internal s = Str.string_match (Str.regexp "^_") s 0 in - `List (List.map makestrpair (List.filter (not -<- is_internal -<- fst) cgi_params))), + Lwt.return (`List (List.map makestrpair (List.filter (not -<- is_internal -<- fst) cgi_params)))), datatype "() ~> [(String,String)]", IMPURE)); @@ -1522,7 +1524,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ (* non-deterministic random number generator *) "random", - (`PFun (fun _ _ -> (Value.box_float (Random.float 1.0))), + (pure_pfun (fun _ -> (Value.box_float (Random.float 1.0))), datatype "() -> Float", IMPURE); @@ -1634,7 +1636,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ "gensym", (let idx = ref 0 in - `PFun (fun _ _ -> let i = !idx in idx := i+1; (Value.box_int i)), + pure_pfun (fun _ -> let i = !idx in idx := i+1; (Value.box_int i)), datatype "() -> Int", IMPURE); @@ -1719,10 +1721,25 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [ (* CLI *) "getArgs", (`Server - (`PFun (fun _ _ -> + (pure_pfun (fun _ -> Value.(box_list (List.map box_string (Settings.get_rest_arguments ()))))), datatype "() ~> [String]", + IMPURE); + + (* SPARQL *) + "sparql", + (`Server + (p3D (fun base uri query _ -> + let base = Iri.of_string (Value.unbox_string base) in + let uri = Uri.of_string(Value.unbox_string uri) in + let query = Value.unbox_string query in + Sparql.select ~base uri query >>= fun result -> + Lwt.return (Value.box_list (List.map (fun s -> + Value.box_list (List.map (fun (k,v) -> + (Value.box_pair (Value.box_string k) (Value.box_string v))) s)) result)))), + datatype "(String,String,String) ~> [[(String,String)]]", IMPURE) + ] let impl : located_primitive -> primitive option = function diff --git a/core/lib.mli b/core/lib.mli index b0d1a534c..96a7c5d50 100644 --- a/core/lib.mli +++ b/core/lib.mli @@ -16,11 +16,11 @@ val nenv : Var.var Env.String.t val primitive_vars : Utility.IntSet.t -val apply_pfun : string -> Value.t list -> RequestData.request_data -> Value.t +val apply_pfun : string -> Value.t list -> RequestData.request_data -> Value.t Lwt.t val primitive_stub : string -> Value.t (* jcheney: added to avoid string comparisons at runtime *) -val apply_pfun_by_code : Var.var -> Value.t list -> RequestData.request_data -> Value.t +val apply_pfun_by_code : Var.var -> Value.t list -> RequestData.request_data -> Value.t Lwt.t val primitive_stub_by_code : Var.var -> Value.t val primitive_name : Var.var -> string diff --git a/core/query/sparql.ml b/core/query/sparql.ml new file mode 100644 index 000000000..d3e059bc8 --- /dev/null +++ b/core/query/sparql.ml @@ -0,0 +1,19 @@ + +open Lwt +open Rdf.Sparql_protocol +open Rdf_sparql_http_lwt + +let internal_error message = + Errors.internal_error ~filename:"query/sparql.ml" ~message + + + +let select ~base uri query = + get ~base ~accept:"application/json" uri {in_query = query; in_dataset = empty_dataset} >>= fun result -> + match result with + | Result(Rdf.Sparql.Solutions ss) -> + Lwt.return (List.map (fun s -> Rdf.Sparql.solution_fold (fun x t l -> (x, Rdf.Term.string_of_term t)::l) s []) ss) + | Result(Rdf.Sparql.Bool _) -> raise (internal_error("expected SELECT query, but result is a boolean")) + | Result(Rdf.Sparql.Graph _) -> raise (internal_error("expected SELECT query, but result is a graph")) + | Ok -> raise (internal_error("expected SELECT query, but no result returned")) + | Error(msg) -> raise (internal_error("SPARQL error: " ^ (Rdf.Sparql_protocol.string_of_error msg))) diff --git a/core/query/sparql.mli b/core/query/sparql.mli new file mode 100644 index 000000000..5424fcd3f --- /dev/null +++ b/core/query/sparql.mli @@ -0,0 +1,16 @@ + +(* Wrapper for running simple SPARQL queries against an endpoint. + * Errors are just thrown as dynamic failures. + * TODO: make better in almost every way. + *) + +(* select base uri query + * - base is the base IRI according to the SPARQL protocol. + * - uri is the URI of the SPARQL endpoint + * - query is the SPARQL query string (unparsed/unchecked) + * it should be a SELECT query returning a list of bindings + * returns: a Links value consisting of a list of association lists + * bound variables in the query result to their bindings + *) + +val select : base:Iri.t -> Uri.t -> string -> (string * string) list list Lwt.t diff --git a/links.opam b/links.opam index 55a6cbae5..8e3d8bebe 100644 --- a/links.opam +++ b/links.opam @@ -37,4 +37,5 @@ depends: [ "menhir" {>= "20210419"} "ppx_sexp_conv" {<= "v0.15.1"} "calendar" {>= "2.0.4"} + "rdf_lwt" {>= "0.13.0"} ]