1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
open Lwt
open Cohttp
open Printf
let fetch_local_uri uri =
let path = Uri.path uri in
try
let ic = open_in path in
let content = really_input_string ic (in_channel_length ic) in
close_in ic;
Ok content
with
| Sys_error err -> Error (Printf.sprintf "Error reading local file %s: %s" path err)
;;
let fetch_uri_lwt ?(debug = false) ~allow_remote uri =
match Uri.scheme uri with
| None ->
if debug then printf "Error: URI %s has no scheme\n" (Uri.to_string uri);
Lwt.return (fetch_local_uri uri)
| Some "file" -> Lwt.return (fetch_local_uri uri)
| Some "http" | Some "https" ->
if not allow_remote
then (
if debug then printf "Skipping remote fetch of %s\n" (Uri.to_string uri);
Lwt.return (Error "Remote fetches disabled"))
else
Cohttp_lwt_unix.Client.get uri
>>= fun (resp, body) ->
let code = resp |> Response.status |> Code.code_of_status in
if debug then printf "Response code: %d\n" code;
if debug then printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
body
|> Cohttp_lwt.Body.to_string
>|= fun body ->
if debug then printf "Body of length: %d\n" (String.length body);
if code >= 200 && code < 300
then Ok body
else Error (Printf.sprintf "HTTP %d: %s" code body)
| Some scheme ->
printf "Error: Unsupported URI scheme %s in URI %s\n" scheme (Uri.to_string uri);
Lwt.return (Error "Unsupported URI scheme")
;;
let fetch_uri_sync ?(debug = false) ~allow_remote uri =
Lwt_main.run (fetch_uri_lwt ~debug ~allow_remote uri)
;;