Simple implementation of SPARQL queries

.github/workflows/default.yml

@@ -17,7 +17,7 @@ jobs:
         os:
           - ubuntu-20.04
         ocaml-compiler:
-          - 4.08.1
+          - 4.14.1
 
     runs-on: ${{ matrix.os }}
 

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)))
 
 

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

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: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
@@ -313,14 +317,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);
 
@@ -360,26 +362,26 @@ 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
   );
 
   "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);
@@ -690,7 +692,7 @@ let env : (string * (located_primitive * Types.datatype * pure)) list = [
   IMPURE);
 
   "print",
-  (p1 (fun msg -> print_string (Value.unbox_string msg); flush stdout; `Record []),
+  (p1D (fun msg _ -> Lwt_io.print (Value.unbox_string msg) >>= fun _ ->  Lwt.return (`Record [])),
    datatype "(String) ~> ()",
   IMPURE);
 
@@ -1029,7 +1031,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) ~> ()",
@@ -1058,7 +1060,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);
 
@@ -1069,7 +1071,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?
@@ -1099,32 +1101,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);
@@ -1197,14 +1199,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",
@@ -1300,8 +1302,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 ->
@@ -1339,7 +1341,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));
 
@@ -1496,7 +1498,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);
 
@@ -1608,7 +1610,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);
 
@@ -1693,10 +1695,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

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

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(Rdf.Sparql_protocol.string_of_error msg))

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

links.opam

@@ -37,4 +37,5 @@ depends: [
   "menhir" {>= "20210419"}
   "ppx_sexp_conv" {<= "v0.15.1"}
   "calendar" {>= "2.0.4"}
+  "rdf_lwt" {>= "0.13.0"}
 ]