steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

socket code fleshed out

cvs
Slava Pestov 2005-04-17 22:34:09 +00:00
parent 94c1a8bcd7
commit aced725ac5
10 changed files with 131 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
library/alien/aliens.factor
View File

@ -27,7 +27,7 @@ M: alien = ( obj obj -- ? )
2drop f
] ifte ;
: ALIEN: scan <alien> swons ; parsing
: ALIEN: scan-word <alien> swons ; parsing
: DLL" skip-blank parse-string dlopen swons ; parsing

2
library/alien/c-types.factor
View File

@ -20,7 +20,7 @@ SYMBOL: c-types
"No such C type: " swap cat2 throw f
] ?ifte ;
: size ( name -- size )
: c-size ( name -- size )
c-type [ "width" get ] bind ;
: define-c-type ( quot name -- )

1
library/alien/structs.factor
View File

@ -56,6 +56,7 @@ math namespaces parser strings words ;
dup define-nth
[
"width" set
cell "align" set
[ swap <displaced-alien> ] "getter" set
] "struct-name" get define-c-type
"void*" c-type "struct-name" get "*" cat2

81
library/httpd/default-responders.factor
View File

@ -1,75 +1,58 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd-responder
USE: httpd
USE: kernel
USE: namespaces
USE: strings
USE: test-responder
USE: inspect-responder
USE: quit-responder
USE: file-responder
USE: resource-responder
USE: cont-responder
USE: browser-responder
USING: browser-responder cont-responder file-responder kernel
namespaces prettyprint quit-responder resource-responder
test-responder ;
#! Remove all existing responders, and create a blank
#! responder table.
global [ <namespace> "httpd-responders" set ] bind
<responder> [
"404" "responder" set
[ drop no-such-responder ] "get" set
] extend add-responder
<responder> [
"test" "responder" set
[ test-responder ] "get" set
] extend add-responder
! This responder lets anybody shut down your httpd. You should
! disable it if you plan on running a production server!
<responder> [
"quit" "responder" set
[ quit-responder ] "get" set
] extend add-responder
<responder> [
"posttest" "responder" set
[ drop "response" get global [ . ] bind ] "post" set
] extend add-responder
! Runs all unit tests and dumps result to the client. This uses
! a lot of server resources, so disable it on a busy server.
<responder> [
"test" "responder" set
[ test-responder ] "get" set
] extend add-responder
! 404 error message pages are served by this guy
<responder> [
"404" "responder" set
[ drop no-such-responder ] "get" set
] extend add-responder
! Serves files from a directory stored in the "doc-root"
! variable. You can set the variable in the global namespace,
! or inside the responder.
<responder> [
! "/var/www/" "doc-root" set
"file" "responder" set
[ file-responder ] "get" set
[ file-responder ] "post" set
[ file-responder ] "head" set
] extend add-responder
! Serves Factor source code
<responder> [
"resource" "responder" set
[ resource-responder ] "get" set
] extend add-responder
! Servers Factor word definitions from the image.
"browser" [ f browser-responder ] install-cont-responder
! The root directory is served by...
"file" set-default-responder

4
library/httpd/httpd.factor
View File

@ -74,3 +74,7 @@ stdio streams strings threads url-encoding ;
: httpd ( port -- )
[ httpd-log-stream "log" set (httpd) ] with-scope ;
: stop-httpd ( -- )
#! Stop the server.
"http-server" get stream-close ;

2
library/httpd/quit-responder.factor
View File

@ -42,5 +42,5 @@ USE: streams
"quit-prohibited" get [
quit-prohibited
] [
"http-server" get stream-close
stop-httpd
] ifte ;

30
library/io/stream.factor
View File

@ -66,13 +66,29 @@ C: wrapper-stream ( stream -- stream )
! Combine an input and output stream into one, and flush the
! stream more often.
TUPLE: talk-stream in out ;
M: talk-stream stream-flush talk-stream-out stream-flush ;
M: talk-stream stream-auto-flush talk-stream-out stream-flush ;
M: talk-stream stream-readln talk-stream-in stream-readln ;
M: talk-stream stream-read talk-stream-in stream-read ;
M: talk-stream stream-write-attr talk-stream-out stream-write-attr ;
M: talk-stream stream-close talk-stream-out stream-close ;
TUPLE: duplex-stream in out flush? ;
M: duplex-stream stream-flush
duplex-stream-out stream-flush ;
M: duplex-stream stream-auto-flush
dup duplex-stream-flush? [
duplex-stream-out stream-flush
] [
drop
] ifte ;
M: duplex-stream stream-readln
duplex-stream-in stream-readln ;
M: duplex-stream stream-read
duplex-stream-in stream-read ;
M: duplex-stream stream-write-attr
duplex-stream-out stream-write-attr ;
M: duplex-stream stream-close
duplex-stream-out stream-close ;
! Reading lines and counting line numbers.
SYMBOL: line-number

13
library/unix/files.factor
View File

@ -1,13 +1,14 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: files
USING: alien io-internals kernel math namespaces ;
! We want the system call stat to shadow the word stat we define
USING: alien io-internals kernel math namespaces unix-internals ;
: cd ( dir -- )
"void" "libc" "chdir" [ "char*" ] alien-invoke ;
: stat ( path -- [ dir? mode size mtime ] )
<stat> tuck sys-stat 0 < [
<stat> tuck stat 0 < [
drop f
] [
[
@ -19,13 +20,13 @@ USING: alien io-internals kernel math namespaces ;
] ifte ;
: (directory) ( path -- list )
sys-opendir [
opendir [
[
[ dirent-name , ] [ dup sys-readdir null>f ] while
] make-list swap sys-closedir
[ dirent-name , ] [ dup readdir null>f ] while
] make-list swap closedir
] [
[ ]
] ifte* ;
: cwd ( -- str )
<string-box> dup 255 sys-getcwd io-error string-box-value ;
<string-box> dup 255 getcwd io-error string-box-value ;

46
library/unix/io.factor
View File

@ -1,8 +1,12 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io-internals
USING: errors generic hashtables kernel lists math namespaces
sequences stdio streams strings threads vectors ;
USING: errors generic hashtables kernel lists math
sequences stdio streams strings threads unix-internals vectors ;
! We want this bind to shadow the bind system call from
! unix-internals
USING: namespaces ;
! These let us load the code into a CFactor instance using the
! old C-based I/O. They will be removed soon.
@ -22,7 +26,7 @@ FORGET: wait-to-write
: io-error ( n -- ) 0 < [ errno strerror throw ] when ;
: init-handle ( fd -- )
F_SETFL O_NONBLOCK 1 sys-fcntl io-error ;
F_SETFL O_NONBLOCK 1 fcntl io-error ;
! Common delegate of native stream readers and writers
TUPLE: port handle buffer error ;
@ -55,14 +59,6 @@ GENERIC: io-task-events ( task -- events )
! this with the hash-size call.
SYMBOL: io-tasks
: init-io ( -- )
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
<namespace> io-tasks set
0 <reader> 1 <writer> <talk-stream> stdio set
] bind ;
: io-task-fd io-task-port port-handle ;
: add-io-task ( callback task -- )
@ -110,12 +106,12 @@ SYMBOL: io-tasks
] keep ;
: io-multiplex ( -- )
make-pollfds 2dup -1 sys-poll drop do-io-tasks io-multiplex ;
make-pollfds 2dup -1 poll drop do-io-tasks io-multiplex ;
! Readers
: open-read ( path -- fd )
O_RDONLY file-mode sys-open dup io-error ;
O_RDONLY file-mode open dup io-error ;
TUPLE: reader line ready? ;
@ -134,7 +130,7 @@ C: reader ( handle -- reader )
"reader not ready" throw
] ifte ;
M: reader stream-close ( stream -- ) port-handle sys-close ;
M: reader stream-close ( stream -- ) port-handle close ;
! Reading lines
: read-line-loop ( line buffer -- ? )
@ -170,7 +166,7 @@ M: reader stream-close ( stream -- ) port-handle sys-close ;
: read-step ( port -- )
>port<
tuck dup buffer-end swap buffer-capacity sys-read
tuck dup buffer-end swap buffer-capacity read
dup 0 >= [ swap n>buffer ] [ drop postpone-error ] ifte ;
: refill ( reader -- )
@ -229,7 +225,7 @@ C: read-task ( port -- task )
: >read-task< dup read-task-count swap io-task-port ;
M: read-task do-io-task
M: read-task do-io-task ( task -- ? )
>read-task< dup refill dup eof? [
nip reader-eof t
] [
@ -254,7 +250,7 @@ M: reader stream-read ( count stream -- string )
! Writers
: open-write ( path -- fd )
O_WRONLY O_CREAT bitor O_TRUNC bitor file-mode sys-open
O_WRONLY O_CREAT bitor O_TRUNC bitor file-mode open
dup io-error ;
TUPLE: writer ;
@ -263,7 +259,7 @@ C: writer ( fd -- writer )
[ >r buffered-port r> set-delegate ] keep ;
: write-step ( fd buffer -- )
tuck dup buffer@ swap buffer-length sys-write dup 0 >= [
tuck dup buffer@ swap buffer-length write dup 0 >= [
swap buffer-consume
] [
drop postpone-error
@ -327,7 +323,11 @@ M: writer stream-write-attr ( string style writer -- )
nip >r dup string? [ ch>string ] unless r> blocking-write ;
M: writer stream-close ( stream -- )
dup stream-flush port-handle sys-close ;
dup stream-flush port-handle close ;
! Make a duplex stream for reading/writing a pair of fds
: <fd-stream> ( infd outfd flush? -- )
>r >r <reader> r> <writer> r> <duplex-stream> ;
! Copying from a reader to a writer
@ -348,3 +348,11 @@ M: writer stream-close ( stream -- )
] [
2drop f
] ifte ;
: init-io ( -- )
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
<namespace> io-tasks set
0 1 t <fd-stream> stdio set
] bind ;

61
library/unix/syscalls.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io-internals
IN: unix-internals
USING: alien errors kernel math namespaces ;
! Alien wrappers for various Unix libc functions.
@ -9,6 +9,7 @@ ALIAS: ulonglong off_t
ALIAS: long ssize_t
ALIAS: ulong size_t
ALIAS: uint socklen_t
ALIAS: uint in_addr_t
BEGIN-STRUCT: stat
FIELD: uint dev
@ -38,10 +39,10 @@ END-STRUCT
: S_IFMT OCT: 0170000 ; inline
: S_ISDIR ( m -- ? ) OCT: 0170000 bitand OCT: 0040000 = ; inline
: sys-stat ( path stat -- n )
: stat ( path stat -- n )
"int" "libc" "stat" [ "char*" "stat*" ] alien-invoke ;
: sys-opendir ( path -- dir* )
: opendir ( path -- dir* )
"void*" "libc" "opendir" [ "char*" ] alien-invoke ;
BEGIN-STRUCT: dirent
@ -52,10 +53,10 @@ BEGIN-STRUCT: dirent
FIELD: uchar256 name
END-STRUCT
: sys-readdir ( dir* -- dirent* )
: readdir ( dir* -- dirent* )
"dirent*" "libc" "readdir" [ "void*" ] alien-invoke ;
: sys-closedir ( dir* -- )
: closedir ( dir* -- )
"void" "libc" "closedir" [ "void*" ] alien-invoke ;
BEGIN-STRUCT: string-box
@ -70,7 +71,7 @@ END-STRUCT
: strerror ( n -- str )
"char*" "libc" "strerror" [ "int" ] alien-invoke ;
: sys-getcwd ( str len -- n )
: getcwd ( str len -- n )
"int" "libc" "getcwd" [ "string-box*" "uint" ] alien-invoke ;
: O_RDONLY HEX: 0000 ;
@ -79,27 +80,27 @@ END-STRUCT
: O_CREAT HEX: 0200 ;
: O_TRUNC HEX: 0400 ;
: sys-open ( path flags prot -- fd )
: open ( path flags prot -- fd )
"int" "libc" "open" [ "char*" "int" "int" ] alien-invoke ;
: sys-close ( fd -- )
: close ( fd -- )
"void" "libc" "close" [ "int" ] alien-invoke ;
: F_SETFL 4 ; ! set file status flags
: O_NONBLOCK 4 ; ! no delay
: sys-fcntl ( fd cmd key value -- n )
: fcntl ( fd cmd key value -- n )
"int" "libc" "fcntl" [ "int" "int" "int" "int" ] alien-invoke ;
: sys-read ( fd buf nbytes -- n )
: read ( fd buf nbytes -- n )
"ssize_t" "libc" "read" [ "int" "ulong" "size_t" ] alien-invoke ;
: sys-write ( fd buf nbytes -- n )
: write ( fd buf nbytes -- n )
"ssize_t" "libc" "write" [ "int" "ulong" "size_t" ] alien-invoke ;
: MSG_OOB HEX: 1 ;
: sys-recv ( fd buf nbytes flags -- )
: recv ( fd buf nbytes flags -- )
"ssize_t" "libc" "read" [ "int" "ulong" "size_t" "int" ] alien-invoke ;
BEGIN-STRUCT: pollfd
@ -119,25 +120,31 @@ END-STRUCT
: read-events POLLIN POLLRDNORM bitor POLLRDBAND bitor ;
: write-events POLLOUT POLLWRNORM bitor POLLWRBAND bitor ;
: sys-poll ( pollfds nfds timeout -- n )
: poll ( pollfds nfds timeout -- n )
"int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ;
BEGIN-STRUCT: void**
FIELD: void* s
END-STRUCT
BEGIN-STRUCT: hostent
FIELD: char* name
FIELD: void* aliases ( really char**)
FIELD: void** aliases
FIELD: int addrtype
FIELD: int length
FIELD: void* addr-list ( really char**)
FIELD: void** addr-list
END-STRUCT
: sys-gethostbyname ( name -- hostent )
: hostent-addr hostent-addr-list 0 swap void**-nth void**-s ;
: gethostbyname ( name -- hostent )
"hostent*" "libc" "gethostbyname" [ "char*" ] alien-invoke ;
BEGIN-STRUCT: sockaddr-in
FIELD: uchar len;
FIELD: uchar family;
FIELD: ushort port;
! FIELD: struct in_addr sin_addr;
FIELD: uchar len
FIELD: uchar family
FIELD: ushort port
FIELD: in_addr_t addr
! FIELD: char sin_zero[8];
END-STRUCT
@ -145,29 +152,29 @@ END-STRUCT
: PF_INET AF_INET ;
: SOCK_STREAM 1 ;
: sys-socket ( domain type protocol -- n )
: socket ( domain type protocol -- n )
"int" "libc" "socket" [ "int" "int" "int" ] alien-invoke ;
: SOL_SOCKET HEX: ffff ; ! options for socket level
: SO_REUSEADDR HEX: 4 ; ! allow local address reuse
: INADDR_ANY 0 ;
: sys-setsockopt ( s level optname optval optlen -- n )
: setsockopt ( s level optname optval optlen -- n )
"int" "libc" "setsockopt" [ "int" "int" "int" "void*" "socklen_t" ] alien-invoke ;
: sys-connect ( s name namelen -- n )
: connect ( s name namelen -- n )
"int" "libc" "connect" [ "int" "sockaddr-in" "socklen_t" ] alien-invoke ;
: sys-bind ( s sockaddr socklen -- n )
: bind ( s sockaddr socklen -- n )
"int" "libc" "bind" [ "int" "sockaddr-in" "socklen_t" ] alien-invoke ;
: sys-listen ( s backlog -- n )
: listen ( s backlog -- n )
"int" "libc" "listen" [ "int" "int" ] alien-invoke ;
: sys-accept ( s sockaddr socklen -- n )
: accept ( s sockaddr socklen -- n )
"int" "libc" "accept" [ "int" "sockaddr-in" "socklen_t" ] alien-invoke ;
: sys-inet-ntoa ( sockaddr -- string )
: inet-ntoa ( sockaddr -- string )
"char*" "libc" "inet_ntoa" [ "sockaddr-in" ] alien-invoke ;
: htonl ( n -- n )