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

Fix conflict

db4
Slava Pestov 2008-05-13 23:50:50 -05:00
parent c60baf1232 09f4e4b032
commit 7ac5747de8
9 changed files with 122 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
extra/ftp/client/client.factor
View File

@ -6,24 +6,6 @@ io.files io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client
TUPLE: ftp-client host port user password mode ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
swap >>host
21 >>port
"anonymous" >>user
"ftp@my.org" >>password ;
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
ftp-response new
V{ } clone >>strings ;
: add-response-line ( ftp-response string -- ftp-response )
over strings>> push ;
: (ftp-response-code) ( str -- n )
3 head string>number ;

18
extra/ftp/ftp.factor
View File

@ -6,4 +6,22 @@ IN: ftp
SINGLETON: active
SINGLETON: passive
TUPLE: ftp-client host port user password mode state ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
swap >>host
21 >>port
"anonymous" >>user
"ftp@my.org" >>password ;
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
ftp-response new
V{ } clone >>strings ;
: add-response-line ( ftp-response string -- ftp-response )
over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ;

79
extra/ftp/server/server.factor
View File

@ -1,15 +1,13 @@
USING: accessors combinators io io.encodings.8-bit
io.server io.sockets kernel sequences ftp
io.unix.launcher.parser unicode.case ;
io.files io.server io.sockets kernel math.parser
namespaces sequences ftp io.unix.launcher.parser
unicode.case ;
IN: ftp.server
TUPLE: ftp-server port ;
: <ftp-server> ( -- ftp-server )
ftp-server new
21 >>port ;
SYMBOL: client
TUPLE: ftp-client-command string tokenized ;
: <ftp-client-command> ( -- obj )
ftp-client-command new ;
@ -17,25 +15,56 @@ TUPLE: ftp-client-command string tokenized ;
<ftp-client-command> readln
[ >>string ] [ tokenize-command >>tokenized ] bi ;
: server>client ( string -- ftp-client-command )
ftp-send read-client-command ;
: send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi
2dup
but-last-slice [
[ number>string write "-" write ] [ ftp-send ] bi*
] with each
first [ number>string write bl ] [ ftp-send ] bi* ;
: send-banner ( -- ftp-client-command )
"220 Welcome to " host-name append server>client ;
: server-response ( n string -- )
<ftp-response>
swap add-response-line
swap >>n
send-response ;
: handle-client-loop ( ftp-client-command -- )
: send-banner ( -- )
220 "Welcome to " host-name append server-response ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: parse-USER ( ftp-client-command -- )
tokenized>> second client get swap >>user drop ;
: send-login-response ( -- )
! client get
230 "Login successful" server-response ;
: parse-PASS ( ftp-client-command -- )
tokenized>> second client get swap >>password drop ;
: send-quit-response ( ftp-client-command -- )
drop 221 "Goodbye." server-response ;
: unimplemented-command ( ftp-client-command -- )
500 "Unimplemented command: " rot string>> append server-response ;
: handle-client-loop ( -- )
<ftp-client-command> readln
[ >>string ] [ tokenize-command >>tokenized ] bi
first >upper {
! { "USER" [ ] }
! { "PASS" [ ] }
[ >>string ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] }
{ "PASS" [ parse-PASS send-login-response t ] }
! { "ACCT" [ ] }
! { "CWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ ] }
! { "QUIT" [ ] }
{ "QUIT" [ send-quit-response f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
@ -66,10 +95,17 @@ TUPLE: ftp-client-command string tokenized ;
! { "SITE" [ ] }
! { "NOOP" [ ] }
} case ;
: handle-client ( -- ftp-response )
! { "EPRT" [ ] }
! { "LPRT" [ ] }
! { "EPSV" [ ] }
! { "LPSV" [ ] }
[ drop unimplemented-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )
"" [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory ;
@ -77,7 +113,8 @@ TUPLE: ftp-client-command string tokenized ;
internet-server "ftp.server"
latin1 [ handle-client ] with-server ;
: ftpd-main ( -- )
2100 ftpd ;
: ftpd-main ( -- ) 2100 ftpd ;
MAIN: ftpd-main
! sudo tcpdump -i en1 -A -s 10000 tcp port 21

3
extra/io/unix/backend/backend.factor
View File

@ -101,8 +101,7 @@ M: integer init-handle ( fd -- )
[ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: integer close-handle ( fd -- )
close ;
M: integer close-handle ( fd -- ) close-file ;
! Readers
: eof ( reader -- )

22
extra/io/unix/files/files.factor
View File

@ -12,21 +12,18 @@ M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
M: unix cd ( path -- )
chdir io-error ;
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <input-port> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
: open-write ( path -- fd )
write-flags file-mode open dup io-error ;
: open-write ( path -- fd ) write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream )
open-write <output-port> ;
@ -34,8 +31,8 @@ M: unix (file-writer) ( path -- stream )
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
: open-append ( path -- fd )
append-flags file-mode open dup io-error
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
append-flags file-mode open-file
[ dup 0 SEEK_END lseek io-error ] [ ] [ close-file ] cleanup ;
M: unix (file-appender) ( path -- stream )
open-append <output-port> ;
@ -46,14 +43,13 @@ M: unix (file-appender) ( path -- stream )
M: unix touch-file ( path -- )
normalize-path
dup exists? [ touch ] [
touch-mode file-mode open close
touch-mode file-mode open-file close-file
] if ;
M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ;
M: unix delete-file ( path -- )
normalize-path unlink io-error ;
M: unix delete-file ( path -- ) normalize-path unlink-file ;
M: unix make-directory ( path -- )
normalize-path OCT: 777 mkdir io-error ;
@ -106,6 +102,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
M: unix read-link ( path -- path' )
normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;
normalize-path read-symbolic-link ;

4
extra/io/unix/launcher/launcher.factor
View File

@ -31,7 +31,7 @@ USE: unix
] when* ;
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
: reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of
@ -44,7 +44,7 @@ USE: unix
: redirect-file ( obj mode fd -- )
>r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ;
open-file r> redirect-fd ;
: redirect-file-append ( obj mode fd -- )
>r drop path>> normalize-path open-append r> redirect-fd ;

6
extra/io/unix/mmap/mmap.factor
View File

@ -4,11 +4,11 @@ USING: alien io io.files kernel math system unix io.unix.backend
io.mmap ;
IN: io.unix.mmap
: open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ;
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
: mmap-open ( length prot flags path -- alien fd )
>r f -roll r> open-r/w [ 0 mmap ] keep
over MAP_FAILED = [ close (io-error) ] when ;
over MAP_FAILED = [ close-file (io-error) ] when ;
M: unix (mapped-file) ( path length -- obj )
swap >r
@ -18,5 +18,5 @@ M: unix (mapped-file) ( path length -- obj )
M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close
mapped-file-handle close-file
io-error ;

16
extra/unix/process/process.factor
View File

@ -1,12 +1,20 @@
USING: kernel alien.c-types alien.strings sequences math unix
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 ;
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
! to implement io.launcher on Unix. User code should use
! io.launcher instead.
FUNCTION: pid_t fork ( ) ;
: fork-process ( -- pid ) [ fork ] unix-system-call ;
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
: >argv ( seq -- alien )
[ utf8 malloc-string ] map f suffix >c-void*-array ;
@ -29,7 +37,7 @@ IN: unix.process
>r [ first ] [ ] bi r> exec-with-env ;
: with-fork ( child parent -- )
fork dup io-error dup zero? -roll swap curry if ; inline
fork-process dup zero? -roll swap curry if ; inline
: wait-for-pid ( pid -- status )
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

28
extra/unix/unix.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc structs sequences
continuations
continuations byte-arrays strings
math namespaces system combinators vocabs.loader qualified
accessors inference macros fry arrays.lib
unix.types ;
@ -69,13 +69,14 @@ FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int chroot ( char* path ) ;
FUNCTION: void close ( int fd ) ;
FUNCTION: int close ( int fd ) ;
: close-file ( fd -- ) [ close ] unix-system-call drop ;
FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int dup2 ( int oldd, int newd ) ;
! FUNCTION: int dup ( int oldd ) ;
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
: _exit ( status -- * )
#! We throw to give this a terminating stack effect.
"int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
@ -83,7 +84,6 @@ FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
FUNCTION: int flock ( int fd, int operation ) ;
FUNCTION: pid_t fork ( ) ;
FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
FUNCTION: int futimes ( int id, timeval[2] times ) ;
FUNCTION: char* gai_strerror ( int ecode ) ;
@ -136,7 +136,17 @@ FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ;
FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
: read-symbolic-link ( path -- path )
PATH_MAX <byte-array> dup >r
PATH_MAX
[ readlink ] unix-system-call
r> swap head-slice >string ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
FUNCTION: int rename ( char* from, char* to ) ;
@ -155,7 +165,11 @@ FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: char* strerror ( int errno ) ;
FUNCTION: int symlink ( char* path1, char* path2 ) ;
FUNCTION: int system ( char* command ) ;
FUNCTION: int unlink ( char* path ) ;
: unlink-file ( path -- ) [ unlink ] unix-system-call drop ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
: SIGKILL 9 ; inline
@ -163,8 +177,6 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
FUNCTION: int kill ( pid_t pid, int sig ) ;
: PATH_MAX 1024 ; inline
: PRIO_PROCESS 0 ; inline
: PRIO_PGRP 1 ; inline
: PRIO_USER 2 ; inline