Use cohttp as HTTP client for planet and CWN

The ocamlnet+gnutls combination is confused by servers that expose
TLS1.3 resulting in errors like `GNUTLS_E_PUSH_ERROR`. This causes many
feeds from planet to fail.

This replaces it with cohttp using openssl as TLS client.
Ocaml-tls is a possible alternative, but when used with cohttp it does
not check server certificates, so it unsuitable for this task.

A drawback is that cohttp does not have redirect logic, so it's
necessary to implement it in here.

Author: emillon

.merlin

@@ -7,5 +7,6 @@ PKG uri
 PKG omd
 PKG opam2web
 PKG cow
+PKG cohttp-lwt-unix
 S script
 B script

.travis.yml

@@ -9,8 +9,6 @@ addons:
     - ocaml-native-compilers
     - opam
     - aspcud
-    - libgnutls28-dev
-    - nettle-dev   # for ocamlnet
 
 script: ./.travis-ci.sh
 env:

Makefile.common

@@ -69,13 +69,13 @@ script/breadcrumb: script/breadcrumb.ml $(UTILS_DEP)
 
 script/rss2html: script/rss2html.ml script/http.ml $(UTILS_DEP)
 	cd script && \
-	$(OCAMLOPT) -package netstring,nettls-gnutls,netclient,syndic \
-	  -linkpkg utils.cmx http.ml rss2html.ml -o ../"$@"
+	$(OCAMLOPT) -package cohttp-lwt-unix,netstring,syndic \
+	  -thread -linkpkg utils.cmx http.ml rss2html.ml -o ../"$@"
 
 script/weekly_news: script/weekly_news.ml script/http.ml $(UTILS_DEP)
 	cd script && \
-	$(OCAMLOPT) -package netstring,nettls-gnutls,netclient,syndic \
-	  -linkpkg utils.cmx http.ml weekly_news.ml -o ../"$@"
+	$(OCAMLOPT) -package cohttp-lwt-unix,netstring,syndic \
+	  -thread -linkpkg utils.cmx http.ml weekly_news.ml -o ../"$@"
 
 script/ocamltohtml:script/lexer.ml script/ocamltohtml.ml
 	cd script && \
@@ -113,10 +113,10 @@ script/translations: script/translations.ml $(UTILS_DEP)
 	  utils.cmx translations.ml
 
 script/%.cmx: script/%.ml script/%.cmi
-	$(OCAMLOPT) -package netstring,nettls-gnutls,netclient,syndic \
+	$(OCAMLOPT) -package netstring,syndic \
 	  -c $< -o $@
 script/%.cmi script/%.cmo: script/%.ml
-	$(OCAMLC) -package netstring,nettls-gnutls,netclient,syndic -c $< -o $@
+	$(OCAMLC) -package netstring,syndic -c $< -o $@
 
 TRASH += template/front_code_snippet.html opam_update_list \
   $(addprefix script/, generate_opam_update_list lang_of_filename translate \

ocamlorg.opam

@@ -11,7 +11,8 @@ depends: [
   "base-bytes" {build}
   "omd" {>= "1.2.1"}
   "ocamlnet" {>= "4.0.1"}
-  "conf-gnutls"
+  "cohttp-lwt-unix"
+  "lwt_ssl"
   "mpp" {>= "0.3.1"}
   "uri" {>= "1.3.11"}
   "syndic" {>= "1.5.2"}

script/http.ml

@@ -3,15 +3,72 @@
    URL. *)
 
 open Printf
-open Nethttp_client.Convenience
 
-let () =
-  Nettls_gnutls.init();
-  Nethttp_client.Convenience.configure_pipeline
-    (fun p ->
-     p#set_options { p#get_options with Nethttp_client.connection_timeout = 5. }
-    )
+exception Error of string
+
+let error fmt = Format.kasprintf (fun s -> raise (Error s)) fmt
+
+let make_uri request_uri uri =
+  let set_host uri =
+    match Uri.host uri with
+    | Some _ -> uri
+    | None ->
+    let request_host = Option.get (Uri.host request_uri) in
+    Uri.with_host uri (Some request_host)
+  in
+  let set_scheme uri =
+    match Uri.scheme uri with
+    | Some _ -> uri
+    | None ->
+    let request_scheme = Option.get (Uri.scheme request_uri) in
+    Uri.with_scheme uri (Some request_scheme)
+  in
+  Uri.of_string uri
+  |> set_host
+  |> set_scheme
+
+let rec http_get_and_follow ~max_redirects uri =
+  let open Lwt in
+  Cohttp_lwt_unix.Client.get uri >>= follow_redirect ~max_redirects uri
 
+and follow_redirect ~max_redirects request_uri (response, body) =
+  let open Lwt in
+  match Cohttp.Response.status response with
+  | `OK -> Lwt.return (response, body)
+  | `Resume_incomplete (* actually 308 Permanent Redirect *)
+  | `Found
+  | `Moved_permanently
+  | `Temporary_redirect -> handle_redirect ~max_redirects request_uri response
+  | `Not_found | `Gone -> error "Not found"
+  | status -> error "Unhandled status: %s" (Cohttp.Code.string_of_status status)
+
+and handle_redirect ~max_redirects request_uri response =
+  if max_redirects <= 0 then
+    error "Too many redirects"
+  else
+    let headers = Cohttp.Response.headers response in
+    let location = Cohttp.Header.get headers "location" in
+    match location with
+    | None -> error "Redirection without Location header"
+    | Some url ->
+      let uri = make_uri request_uri url in
+      http_get_and_follow uri ~max_redirects:(max_redirects - 1)
+
+let http_get url =
+  let max_redirects = 10 in
+  let timeout = 5. in
+  try
+    Lwt_main.run (
+      Lwt_unix.with_timeout timeout (fun () ->
+        let open Lwt in
+        let uri = Uri.of_string url in
+        http_get_and_follow ~max_redirects uri >>= fun (_response, body) ->
+        Cohttp_lwt.Body.to_string body)
+    )
+  with
+  | Lwt_unix.Timeout -> error "Timeout"
+  | Unix.Unix_error _ -> error "Unknown"
+  | Ssl.Connection_error _ ->  error "SSL connection error"
 
 let age fn =
   let now = Unix.time () in (* in sec *)
@@ -46,7 +103,7 @@ let get ?(cache_secs=cache_secs) url =
       close_out fh;
       eprintf "(cached).\n%!";
       data
-    with Nethttp_client.Http_protocol _ as e ->
+    with Error _ as e ->
       if Sys.file_exists fn then get_from_cache()
       else (
         eprintf "FAILED!\n%!";

script/rss2html.ml

@@ -163,18 +163,10 @@ let feed_of_url ~name url =
   with
   | Rss2.Error.Error _ ->
       broken_feed name url "Neither an Atom nor a RSS2 feed"
-  | Nethttp_client.Http_protocol(Nethttp_client.Timeout s)
-  | Nethttp_client.Http_protocol(Nethttp_client.Name_resolution_error s) ->
-     broken_feed name url s
-  | Nethttp_client.Http_protocol Nethttp_client.Too_many_redirections ->
-     broken_feed name url "Too many redirections"
-  | Nethttp_client.Http_protocol e ->
-     broken_feed name url (Printexc.to_string e)
-  | Nethttp_client.Http_error(err, _) ->
-     let msg = Nethttp.(string_of_http_status (http_status_of_int err)) in
-     broken_feed name url msg
   | Invalid_argument msg ->     (* e.g. Syndic.Date.of_string *)
      broken_feed name url ("Invalid_argument: " ^ msg)
+  | Http.Error s ->
+     broken_feed name url ("HTTP error: " ^ s)
 
 let planet_feeds =
   let add_feed acc line =