Merge pull request #97 from cgay/test-executables

Basic support for HTTPS in http-client

README.rst

@@ -29,15 +29,9 @@ Testing
 As of Dec 2020 there are serious problems with the tests and many of them hang.
 Fixing this should be #1 priority.
 
-However, in general, to run all the tests::
+However, to run all the tests::
 
-  $ dylan-compiler -build http-test-suite
-  $ dylan-compiler -build testworks-run
-  $ _build/bin/testworks-run --load libhttp-test-suite.so
-
-Or you may run one of the more specific test suites::
-
-  $ _build/bin/testworks-run --load libhttp-server-test-suite.so
-  $ _build/bin/testworks-run --load libhttp-client-test-suite.so
-  $ _build/bin/testworks-run --load libhttp-common-test-suite.so
-  $ _build/bin/testworks-run --load libhttp-protocol-test-suite.so
+  $ for suite in common client server; do
+      dylan-compiler -build http-${suite}-test-suite
+      _build/bin/http-${suite}-test-suite
+    done

client/http-client.dylan

@@ -13,10 +13,6 @@ TODO:
 * Optional strict mode in which reads/writes signal an error if the
   chunk size is wrong or content length is wrong.  Give the user a way
   to recover from the error.
-* This code isn't currently designed to support HTTP over anything
-  other than a <tcp-socket>.  It does not support <ssl-socket>s. (It's
-  also conceivable for there to be an <ipc-socket> class.)
-
 */
 
 define constant $default-http-port :: <integer> = 80;
@@ -57,7 +53,7 @@ end;
 // after which one reads from the response object itself.
 //
 define open class <http-connection> (<basic-stream>)
-  slot connection-socket :: <tcp-socket>;
+  slot connection-socket :: <tcp-socket>; // can be <ssl-socket>
   slot connection-host :: <string>;
 
   slot outgoing-chunk-size :: <integer> = 8192,
@@ -68,7 +64,6 @@ define open class <http-connection> (<basic-stream>)
   slot write-buffer-index :: <integer> = 0;
   // Number of bytes written so far for the current request message body only.
   slot message-bytes-written :: <integer> = 0;
-
 end class <http-connection>;
 
 define method initialize
@@ -511,44 +506,35 @@ end method read-status-line;
 ///////////////////////////////////////////
 
 define function make-http-connection
-    (host-or-url, #rest initargs, #key port, #all-keys)
-  let host = host-or-url;
-  // It's convenient to be able to use a string for the URL.
-  if (instance?(host, <string>) & any?(member?(_, host), "/:"))
-    host := parse-url(host);
+    (uri :: <uri>, #rest initargs) => (conn :: <http-connection>)
+  let host = uri-host(uri);
+  if (empty?(host))
+    error("The URI provided, %s, must have a host component.", build-uri(uri));
   end;
-  if (instance?(host, <uri>))
-    let uri :: <uri> = host;
-    host := uri-host(uri);
-    if (empty?(host))
-      error("The URI provided, %s, must have a host component.",
-            build-uri(uri));
-    end if;
-    port := port | uri.uri-port;
-    if (~port)
-      // TODO(cgay): The uri library should supply port defaults for schemes
-      // that specify it, so we don't have to do this here.
-      select (uri.uri-scheme by  string-equal-ic?)
-        "http", "" => port := $default-http-port;
-        "https"    => port := $default-https-port;
-        otherwise => error("The URI provided, %s, must be an http or https URI.",
-                           build-uri(uri));
-      end;
-    end;
-  end if;
-  apply(make, <http-connection>, host: host, port: port, initargs)
+  let ssl? = #f;
+  let port = select (uri.uri-scheme by  string-equal-ic?)
+               "http"  =>
+                 uri.uri-port | $default-http-port;
+               "https" =>
+                 ssl? := #t;
+                 uri.uri-port | $default-https-port;
+               otherwise =>
+                 error("The URI provided, %s, must be an http or https URI.",
+                       build-uri(uri));
+             end;
+  apply(make, <http-connection>, host: host, port: port, ssl?: ssl?, initargs)
 end function make-http-connection;
 
 // with-http-connection(conn = url) blah end;
 // with-http-connection(conn = host, ...<http-connection> initargs...) blah end;
 //
 define macro with-http-connection
-  { with-http-connection (?conn:name = ?host-or-url:expression, #rest ?initargs:*)
+  { with-http-connection (?conn:name = ?url:expression, #rest ?initargs:*)
       ?:body
     end }
     => { let _conn = #f;
          block ()
-           _conn := make-http-connection(?host-or-url, ?initargs);
+           _conn := make-http-connection(?url, ?initargs);
            let ?conn = _conn;
            // Bind *http-connection* so that start-request knows it should add
            // a "Connection: Keep-alive" header if no Connection header is present.

client/library.dylan

@@ -11,6 +11,7 @@ define library http-client
   use logging;
   use network,
     import: { sockets };
+  use ssl-network;
   use strings;
   use system,
     import: { threads };
@@ -72,6 +73,8 @@ define module http-client-internals
   use logging;
   use sockets,
     exclude: { start-server };
+  // ssl-sockets loaded for side-effects: sideways methods on ssl-[server-]socket-class.
+  use ssl-sockets;
   use standard-io;
   use streams;
   use strings;

client/tests/http-client-test-suite-library.dylan

@@ -10,6 +10,8 @@ define library http-client-test-suite
   use http-common;
   use http-server;
   use http-testing;
+  use network;
+  use ssl-network;
   use testworks;
   use uri;
   use strings;
@@ -27,6 +29,9 @@ define module http-client-test-suite
   use http-common;
   use http-server;
   use http-testing;
+  use sockets,
+    import: { start-sockets };
+  use ssl-sockets;              // for side-effect
   use testworks;
   use uri;
   use streams;

client/tests/http-client-test-suite.dylan

@@ -2,7 +2,6 @@ Module: http-client-test-suite
 Author: Francesco Ceccon
 Copyright: See LICENSE in this distribution for details.
 
-
 define test test-convert-headers-method ()
   let headers = convert-headers(#f);
   check-instance?("#f is an empty <header-table>", <header-table>, headers);
@@ -266,6 +265,20 @@ define test test-redirect-loop-detection ()
   end;
 end test test-redirect-loop-detection;
 
+define test test-https ()
+  // This puts a dependency on github.com and on the network being up while
+  // this test suite is run, but the test infrastructure to set up an https
+  // server side doesn't yet exist. TODO...
+  //
+  // This is a convenient case where I happen to know it should return a 302
+  // with a specific Location header.
+  let res = http-get("https://github.com/dylan-lang/pacman-catalog/releases/latest",
+                     follow-redirects: #f);
+  assert-equal(302, res.response-code);
+  assert-true(starts-with?(get-header(res, "Location"),
+                           "https://github.com/dylan-lang/pacman-catalog/releases/tag/"));
+end;
+
 define suite http-client-test-suite ()
   test test-http-get-to-string;
   test test-http-get-to-stream;
@@ -295,3 +308,8 @@ define suite http-client-test-suite ()
 
   // TODO: test the reaction to server errors
 end suite http-client-test-suite;
+
+begin
+  start-sockets();
+  run-test-application()
+end

common/tests/http-common-test-suite-library.dylan

@@ -5,6 +5,8 @@ Copyright: See LICENSE in this distribution for details.
 define library http-common-test-suite
   use common-dylan;
   use http-common;
+  use network;
+  use ssl-network;
   use testworks;
   use io;
   export http-common-test-suite;
@@ -14,6 +16,9 @@ define module http-common-test-suite
   use common-dylan;
   use http-common;
   use http-common-internals;
+  use sockets,
+    import: { start-sockets };
+  use ssl-sockets;              // for side-effect
   use streams;
   use testworks;
   use format;

common/tests/http-common-test-suite.dylan

@@ -152,3 +152,8 @@ define test test-media-type-level ()
               make-media-type("a", "b", #["level", 2]).media-type-level);
   check-false("Default level is #f?", make-media-type("a", "b").media-type-level);
 end test;
+
+begin
+  start-sockets();
+  run-test-application()
+end

server/tests/http-server-test-suite-library.dylan

@@ -20,6 +20,7 @@ define library http-server-test-suite
   use mime;
   use network,
     import: { sockets };
+  use ssl-network;
   use regular-expressions;
   use strings;
   use system,
@@ -64,6 +65,7 @@ define module http-server-test-suite
       <address-in-use>,
       start-sockets
     };
+  use ssl-sockets;              // for side-effect
   use streams;
   use strings;
   use testworks;

server/tests/http-server-tests.dylan

@@ -106,3 +106,8 @@ define suite http-server-test-suite ()
   suite virtual-host-test-suite;
   suite request-test-suite;
 end;
+
+begin
+  start-sockets();
+  run-test-application()
+end

tests/http-protocol-test-suite-library.dylan

@@ -7,6 +7,8 @@ define library http-protocol-test-suite
   use http-client;
   use http-common;
   use http-testing;
+  use network;
+  use ssl-network;
   use testworks;
   use uri;
   use strings;
@@ -21,6 +23,9 @@ define module http-protocol-test-suite
   use http-common;
   use http-testing,
     import: { fmt };
+  use sockets,
+    import: { start-sockets };
+  use ssl-sockets;              // for side-effect
   use testworks;
   use uri;
   use strings;

tests/http-protocol-test-suite.dylan

@@ -136,3 +136,8 @@ end test;
 define test test-cookies-on-redirect ()
   // This test requires a class to persist status between requests (session?)
 end test;
+
+begin
+  start-sockets();
+  run-test-application()
+end

tests/http-testing-library.dylan

@@ -7,6 +7,7 @@ define library http-testing
   use http-common;
   use http-server;
   use logging;
+  use network;
   use uri;
   use io, import: { format };
 
@@ -22,6 +23,8 @@ define module http-testing
     exclude: { log-trace, log-debug, log-info, log-warning, log-error };
   use logging,
     import: { <log>, log-level-setter, $debug-level };
+  use sockets,
+    import: { start-sockets };
   use uri,
     import: { parse-url, <url> };
 

tests/http-testing.dylan

@@ -89,3 +89,6 @@ define function make-x-url
   test-url(format-to-string("/x?n=%d", n))
 end;
 
+begin
+  start-sockets();
+end;