#!/usr/bin/env scheme-script
;; -*- mode: scheme; coding: utf-8 -*- !#
;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
#!r6rs

(import (prefix (weinholt crypto x509) x509:)
        (weinholt net tls)
        (weinholt net tls simple)
        (rnrs))

(define (print . x) (for-each display x) (newline))

(let-values (((in out conn)
              (tls-connect (cadr (command-line))
                           (caddr (command-line)))))

  (print "Server certificate validation: "
         (x509:validate-certificate-path (tls-conn-remote-certs conn)
                                         (cadr (command-line))))

  (print "Sending GET request.")
  
  (put-bytevector out (string->utf8
                       (string-append "GET / HTTP/1.1\r\n"
                                      "Host: " (cadr (command-line)) ":" (caddr (command-line)) "\r\n"
                                      "Connection: close\r\n"
                                      "\r\n\r\n")))
  (flush-output-port out)
  (let lp ()
    (unless (port-eof? in)
      (display (utf8->string (get-bytevector-n in 128)))
      (lp)))
  (close-port in)
  (close-port out))
