From 4f0a8162957349fa15a86c895d6afcf52b9d3382 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Wed, 26 Dec 2007 17:35:58 -0500 Subject: [PATCH] Added a tcp-connect procedure that takes a host name and a service name (e.g. "www.google.com" and "http") and returns two binary ports: the first for output and the second for input. Both ports must be closed for the connection to close. Also added an example in lab/tcp-connect-example.ss which connects to an http server, sends "GET /\n" and prints the responde. --- lab/tcp-connect-example.ss | 19 ++++++++++++ scheme/ikarus.io.ss | 57 ++++++++++++++++++++++++++---------- scheme/last-revision | 2 +- scheme/makefile.ss | 1 + src/ikarus-io.c | 60 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 122 insertions(+), 17 deletions(-) create mode 100755 lab/tcp-connect-example.ss diff --git a/lab/tcp-connect-example.ss b/lab/tcp-connect-example.ss new file mode 100755 index 0000000..7cba133 --- /dev/null +++ b/lab/tcp-connect-example.ss @@ -0,0 +1,19 @@ +#!/usr/bin/env scheme-script + +(import (ikarus)) + +;;; very simple demo for how to connect to a server, +;;; send a request and receive a response. + +(define (http-cat host) + (let-values ([(op ip) (tcp-connect host "http")]) + (let ([op (transcoded-port op (native-transcoder))] + [ip (transcoded-port ip (native-transcoder))]) + (display "GET /\n" op) + (display (get-string-all ip)) + (close-input-port ip) + (close-output-port op)))) + +;(http-cat "www.google.com") +(http-cat "127.0.0.1") + diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index ac3f3cb..6f29717 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -61,7 +61,10 @@ reset-input-port! port-id input-port-byte-position - process ) + process + + tcp-connect + ) (import @@ -111,7 +114,8 @@ reset-input-port! port-id input-port-byte-position - process)) + process + tcp-connect)) (module UNSAFE (fx< fx<= fx> fx>= fx= fx+ fx- @@ -1180,7 +1184,7 @@ (define input-file-buffer-size (+ block-size 128)) (define output-file-buffer-size block-size) - (define (fh->input-port fd id size transcoder close?) + (define (fh->input-port fd id size transcoder close) (guarded-port ($make-port (input-transcoder-attrs transcoder) @@ -1196,15 +1200,13 @@ #f ;;; write! #f ;;; get-position #f ;;; set-position! - (and close? - (lambda () - (cond - [(foreign-call "ikrt_close_fd" fd) => - (lambda (err) - (io-error 'close id err))]))) + (cond + [(procedure? close) close] + [(eqv? close #t) (file-close-proc id fd)] + [else #f]) fd))) - (define (fh->output-port fd id size transcoder close?) + (define (fh->output-port fd id size transcoder close) (guarded-port ($make-port (output-transcoder-attrs transcoder) @@ -1220,14 +1222,19 @@ bytes)) #f ;;; get-position #f ;;; set-position! - (and close? - (lambda () - (cond - [(foreign-call "ikrt_close_fd" fd) => - (lambda (err) - (io-error 'close id err))]))) + (cond + [(procedure? close) close] + [(eqv? close #t) (file-close-proc id fd)] + [else #f]) fd))) + (define (file-close-proc id fd) + (lambda () + (cond + [(foreign-call "ikrt_close_fd" fd) => + (lambda (err) + (io-error 'close id err))]))) + (define (open-input-file-handle filename who) (let ([fh (foreign-call "ikrt_open_input_fd" (string->utf8 filename))]) @@ -1902,6 +1909,24 @@ (fh->input-port (vector-ref r 3) cmd input-file-buffer-size #f #t))))) + (define (tcp-connect host srvc) + (let ([socket (foreign-call "ikrt_tcp_connect" + (string->utf8 host) + (string->utf8 srvc))]) + (if (< socket 0) + (io-error 'tcp-connect host socket) + (let ([close + (let ([closed-once? #f]) + (lambda () + (if closed-once? + ((file-close-proc host socket)) + (set! closed-once? #t))))]) + (values + (fh->output-port socket + host output-file-buffer-size #f close) + (fh->input-port socket + host input-file-buffer-size #f close)))))) + ) diff --git a/scheme/last-revision b/scheme/last-revision index 80a6100..c83b067 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1288 +1289 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 798f887..d656e06 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1373,6 +1373,7 @@ [&no-nans-rcd] [&interrupted-rtd] [&interrupted-rcd] + [tcp-connect i] )) (define (macro-identifier? x) diff --git a/src/ikarus-io.c b/src/ikarus-io.c index 8c15997..354205c 100644 --- a/src/ikarus-io.c +++ b/src/ikarus-io.c @@ -5,6 +5,8 @@ #include #include #include +#include +#include #include "ikarus-data.h" @@ -112,3 +114,61 @@ ikrt_write_fd(ikptr fd, ikptr bv, ikptr off, ikptr cnt, ikpcb* pcb){ } } +char* get_family(int x){ + if (x == AF_UNIX) return "AF_UNIX"; + if (x == AF_INET) return "AF_INET"; + if (x == AF_ISO) return "AF_ISO"; + if (x == AF_NS) return "AF_NS"; + if (x == AF_IMPLINK) return "AF_IMPLINK"; + return "AF_UNKNOWN"; +} + +char* get_type(int x){ + if (x == SOCK_STREAM) return "SOCK_STREAM"; + if (x == SOCK_DGRAM) return "SOCK_DGRAM"; + if (x == SOCK_RAW) return "SOCK_RAW"; + if (x == SOCK_SEQPACKET) return "SOCK_SEQPACKET"; + if (x == SOCK_RDM) return "SOCK_RDM"; + return "SOCK_UNKNOWN"; +} + +ikptr +ikrt_tcp_connect(ikptr host, ikptr srvc, ikpcb* pcb){ + struct addrinfo* info; + int err = getaddrinfo(host+off_bytevector_data, + srvc+off_bytevector_data, + 0, + &info); + if(err){ + return fix(-1); + } + struct addrinfo* i = info; + int sock = -1; + while(i){ + if(i->ai_socktype != SOCK_STREAM){ + i = i->ai_next; + } else { + int s = socket(i->ai_family, i->ai_socktype, i->ai_protocol); + if(s < 0){ + i = i->ai_next; + } else { + int err = connect(s, i->ai_addr, i->ai_addrlen); + if(err < 0){ + i = i->ai_next; + } else { + sock = s; + i = 0; + } + } + } + } + freeaddrinfo(info); + return fix(sock); +} + +//ikptr +//ikrt_tcp_connect(ikp host, ikp port, ikpcb* pcb){ +// +//} + +