add flag handling to aslp-server

bin/asli.ml

@@ -33,15 +33,6 @@ let () = Printexc.register_printer
         Some (Printf.sprintf "EvalError at %s: %s" (pp_loc loc) msg)
     | _ -> None)
 
-let flags = [
-    ("trace:write", Eval.trace_write);
-    ("trace:fun",   Eval.trace_funcall);
-    ("trace:prim",  Eval.trace_primop);
-    ("trace:instr", Eval.trace_instruction);
-    ("eval:concrete_unknown", Value.concrete_unknown);
-    ("dis:vectoriser", Dis.use_vectoriser);
-]
-
 let help_msg = [
     {|:? :help                       Show this help message|};
     {|:elf <file>                    Load an ELF file|};
@@ -69,16 +60,6 @@ let gen_backends = [
     ("cpp",   (Cpu.Cpp, "offlineASL-cpp"));
 ]
 
-let set_flag s =
-    if not (Utils.startswith s "+" || Utils.startswith s "-") then
-        raise @@ Arg.Bad "flag should start with + to set and - to unset";
-    let flags_str = String.concat ", " @@ List.map fst flags in
-    let flag = Utils.stringDrop 1 s in
-
-    (match List.assoc_opt flag flags with
-    | None -> raise @@ Arg.Bad (Printf.sprintf "unknown flag '%s'\navailable flags: %s" flag flags_str);
-    | Some f -> f := Utils.startswith flag "+")
-
 let () = Random.self_init ()
 
 let rec process_command (tcenv: TC.Env.t) (cpu: Cpu.cpu) (fname: string) (input0: string): unit =
@@ -176,7 +157,7 @@ let rec process_command (tcenv: TC.Env.t) (cpu: Cpu.cpu) (fname: string) (input0
     | [":help"] | [":?"] ->
         List.iter print_endline help_msg;
         print_endline "\nFlags:";
-        List.iter (fun (nm, v) -> Printf.printf "  %s%s\n" (if !v then "+" else "-") nm) flags
+        Flags.StringMap.iter (fun nm v -> Printf.printf "  %s%s\n" (if v then "+" else "-") nm) (Flags.get_flags ())
     | [":opcode"; iset; opcode] ->
         (* todo: make this code more robust *)
         let op = Z.of_string opcode in
@@ -248,7 +229,7 @@ let rec process_command (tcenv: TC.Env.t) (cpu: Cpu.cpu) (fname: string) (input0
     | (":set" :: "impdef" :: rest) ->
         Eval.set_impdef tcenv cpu.env fname rest
     | [":set"; flag] ->
-        set_flag flag
+        Flags.set_flag flag
     | [":project"; prj] ->
         let inchan = open_in prj in
         (try
@@ -315,7 +296,7 @@ let options = Arg.align ([
     ( "--export-aarch64", Arg.Set_string opt_export_aarch64_dir,  "       Export bundled AArch64 MRA to the given directory");
     ( "--version", Arg.Set opt_print_version, "       Print version");
     ( "--prelude", Arg.Set_string opt_prelude,"       ASL prelude file (default: ./prelude.asl)");
-    ( "--flag", Arg.String set_flag,          "       Behaviour flags to set (+) or unset (-)");
+    ( "--flag", Arg.String Flags.set_flag,          "       Behaviour flags to set (+) or unset (-)");
 ] )
 
 let version = "ASL 0.2.0 alpha"

bin/server.ml

@@ -29,7 +29,6 @@ let eval_instr (opcode: string) : string * string =
     let stmts'   = List.map pp_raw stmts in
     enc, String.concat "\n" stmts'
 
-
 let get_reply (jsonin: string) : Cohttp.Code.status_code * string =
   (*let json  = Yojson.Safe.from_string jsonin in *)
   let make_reply code tail =
@@ -47,26 +46,37 @@ let unsupp_method_resp : Cohttp.Code.status_code * string =
 let missing_param : Cohttp.Code.status_code * string =
   (`Bad_request, Yojson.Safe.to_string (`Assoc [("error", `String "missing opcode param.")]))
 
-(*let () = ignore (List.map (fun (f: string) -> print_endline (eval_instr f)) (tl (to_list Sys.argv))) *)
-
+let try_set_flags xs : (unit, Cohttp.Code.status_code * string) Result.t =
+  match (List.iter Flags.set_flag xs) with
+  | exception (Arg.Bad _ as e) -> Result.error (`Bad_request, Yojson.Safe.to_string (`Assoc [("error", `String (Printexc.to_string e))]))
+  | _ -> Result.ok ()
 
 let get_resp (opcode: string) : Cohttp.Code.status_code * string =
     get_reply opcode
 
 let server addr port =
   Printf.printf "Started aslp-server at http://%s:%d\n" addr port;
   flush stdout;
+
+  let oldflags = Flags.get_flags () in
+
   let callback _conn req body =
     let uri = req |> Request.uri in
     let _meth = req |> Request.meth |> Code.string_of_method in
     let _headers = req |> Request.headers |> Header.to_string in
     let body' = body |> Cohttp_lwt.Body.to_string in
-    let resp' =
-      match (Request.meth req, Uri.get_query_param uri "opcode") with
-      | `POST, _ -> body' >|= get_resp
-      | `GET, Some param -> Lwt.return (get_resp param)
-      | `GET, None -> Lwt.return missing_param
-      |  _ -> Lwt.return unsupp_method_resp
+
+    Flags.set_flags oldflags;
+
+    let resp' = 
+      match (Option.map try_set_flags (Uri.get_query_param' uri "flags")) with
+      | Some (Error xs) -> Lwt.return xs
+      | Some (Ok ()) | None ->
+        match (Request.meth req, Uri.get_query_param uri "opcode") with
+        | `POST, _ -> body' >|= get_resp
+        | `GET, Some param -> Lwt.return (get_resp param)
+        | `GET, None -> Lwt.return missing_param
+        |  _ -> Lwt.return unsupp_method_resp
     in
     resp' >>= fun (code, body) -> Server.respond_string ~status:code ~body ()
   in

libASL/dune

@@ -39,7 +39,7 @@
    lexer lexersupport loadASL monad primops rws symbolic tcheck testing transforms value
    symbolic_lifter decoder_program call_graph req_analysis
    offline_transform ocaml_backend dis_tc offline_opt
-   arm_env pretransforms
+   arm_env pretransforms flags
    )
  (preprocessor_deps (alias ../asl_files))
  (preprocess (pps ppx_blob))

libASL/flags.ml

@@ -0,0 +1,28 @@
+module StringMap = Map.Make(String)
+
+let flags = StringMap.of_seq @@ List.to_seq [
+    ("trace:write", Eval.trace_write);
+    ("trace:fun",   Eval.trace_funcall);
+    ("trace:prim",  Eval.trace_primop);
+    ("trace:instr", Eval.trace_instruction);
+    ("eval:concrete_unknown", Value.concrete_unknown);
+    ("dis:vectors", Dis.use_vectoriser);
+]
+
+let set_flag s =
+    let plus = Utils.startswith s "+" in
+    let minus = Utils.startswith s "-" in
+    if not (plus || minus) then
+        raise @@ Arg.Bad "flag should start with + to set and - to unset";
+    let flags_str = String.concat ", " @@ List.map fst (StringMap.bindings flags) in
+    let flag = Utils.stringDrop 1 s in
+
+    match StringMap.find_opt flag flags with
+    | None -> raise @@ Arg.Bad (Printf.sprintf "unknown flag '%s'\navailable flags: %s" flag flags_str);
+    | Some f -> f := plus
+
+let get_flags () =
+    StringMap.map (fun x -> !x) flags
+
+let set_flags xs =
+    StringMap.iter (fun k v -> StringMap.find k flags := v) xs;