-- telnetd should use multitasking\r
-- file-responder: Content-Length\r
-- HEAD request for file-responder\r
- - nicer way to combine two paths\r
- - icons for file responder\r
+- TEST telnetd should use multitasking\r
+- quit responder breaks with multithreading\r
+- nicer way to combine two paths\r
+- icons for file responder\r
- -1.1 3 ^ shouldn't give a complex number\r
- don't show listener on certain commands\r
- inferior hangs\r
- introduce ifte* and ?str-head/?str-tail where appropriate\r
- cwd, cd, pwd, dir., pwd. words\r
- namespace clone drops static var bindings\r
+- f usages. --> don't print all words\r
\r
+ bignums:\r
\r
+ httpd:\r
\r
- 'default responder' for when we go to root\r
-- quit responder breaks with multithreading\r
- wiki responder:\r
- port to native\r
- text styles\r
VFSManager.waitForRequests();
FactorPlugin.eval(view,
"\""
- + factor.FactorReader.charsToEscapes(buffer.path)
+ + FactorReader.charsToEscapes(buffer.path)
+ "\" run-file");
</CODE>
</ACTION>
<ACTION NAME="factor-apropos">
<CODE>
- if(textArea.selectionCount == 0)
- textArea.selectWord();
- FactorPlugin.eval(view,
- "\""
- + factor.FactorReader.charsToEscapes(
- textArea.selectedText)
- + "\" apropos.");
+ word = FactorPlugin.getWordAtCaret(textArea);
+ if(word == null)
+ view.toolkit.beep();
+ else
+ {
+ FactorPlugin.eval(view,
+ "\""
+ + FactorReader.charsToEscapes(word)
+ + "\" apropos.");
+ }
</CODE>
</ACTION>
<ACTION NAME="factor-see">
</ACTION>
<ACTION NAME="factor-insert-use">
<CODE>
- if(textArea.selectionCount == 0)
- textArea.selectWord();
- FactorPlugin.insertUseDialog(view,
- textArea.selectedText);
+ word = FactorPlugin.getWordAtCaret(textArea);
+ if(word == null)
+ view.toolkit.beep();
+ else
+ FactorPlugin.insertUseDialog(view,word);
</CODE>
</ACTION>
</ACTIONS>
private static FactorInterpreter interp;
+ //{{{ start() method
+ public void start()
+ {
+ BeanShell.eval(null,BeanShell.getNameSpace(),
+ "import factor.*;\nimport factor.jedit.*;\n");
+ } //}}}
+
//{{{ getInterpreter() method
/**
* This can be called from the SideKick thread and must be thread safe.
<responder> [
"file" "responder" set
[ file-responder ] "get" set
+ [ file-responder ] "post" set
+ [ file-responder ] "head" set
] extend "file" set
! <responder> [
USE: httpd
USE: httpd-responder
USE: kernel
+USE: lists
USE: logging
USE: namespaces
USE: parser
USE: stdio
USE: streams
USE: strings
+USE: unparser
: serving-path ( filename -- filename )
f>"" "doc-root" get swap cat2 ;
-: file-header ( mime-type -- header )
- "200 Document follows" swap response ;
-
: copy-and-close ( from -- )
[ dupd "stdio" get fcopy ] [ >r fclose r> rethrow ] catch ;
+: file-response ( mime-type length -- )
+ [,
+ unparse "Content-Length" swons ,
+ "Content-Type" swons ,
+ ,] "200 OK" response ;
+
: serve-static ( filename mime-type -- )
- file-header print <filebr> "stdio" get fcopy ;
+ over file-length file-response "method" get "head" = [
+ drop
+ ] [
+ <filebr> "stdio" get copy-and-close
+ ] ifte ;
: serve-file ( filename -- )
dup mime-type dup "application/x-factor-server-page" = [
%> redirect ;
: list-directory ( directory -- )
- serving-html dup [ directory. ] simple-html-document ;
+ serving-html
+ "method" get "head" = [
+ drop
+ ] [
+ dup [ directory. ] simple-html-document
+ ] ifte ;
: serve-directory ( filename -- )
"/" ?str-tail [
: serve-object ( filename -- )
dup directory? [ serve-directory ] [ serve-file ] ifte ;
-: file-responder ( filename -- )
+: file-responder ( filename method -- )
"doc-root" get [
serving-path dup exists? [
serve-object
] [
- drop "404 not found" httpd-error
+ 2drop "404 not found" httpd-error
] ifte
] [
- drop "404 doc-root not set" httpd-error
+ 2drop "404 doc-root not set" httpd-error
] ifte ;
USE: url-encoding
-: response ( msg content-type -- response )
- swap <% "HTTP/1.0 " % % "\nContent-Type: " % % "\n" % %> ;
+: print-header ( alist -- )
+ [ unswons write ": " write url-encode print ] each ;
-: response-write ( msg content-type -- )
- response print ;
+: response ( header msg -- )
+ "HTTP/1.0 " write print print-header ;
: error-body ( error -- body )
- "\n<html><body><h1>" swap "</h1></body></html>" cat3 ;
+ "<html><body><h1>" swap "</h1></body></html>" cat3 print ;
-: httpd-error ( error -- )
+: error-head ( error -- )
dup log-error
- <% dup "text/html" response % error-body % %> print ;
+ [ [ "Content-Type" | "text/html" ] ] over response ;
+
+: httpd-error ( error -- )
+ #! This must be run from handle-request
+ error-head
+ "head" "method" get = [ terpri error-body ] unless ;
+
+: bad-request ( -- )
+ [
+ ! Make httpd-error print a body
+ "get" "method" set
+ "400 Bad request" httpd-error
+ ] with-scope ;
: serving-html ( -- )
- "200 Document follows" "text/html" response print ;
+ [ [ "Content-Type" | "text/html" ] ]
+ "200 Document follows" response terpri ;
: serving-text ( -- )
- "200 Document follows" "text/plain" response print ;
+ [ [ "Content-Type" | "text/plain" ] ]
+ "200 Document follows" response terpri ;
: redirect ( to -- )
- "301 Moved Permanently" "text/plain" response write
- "Location: " write write
- terpri terpri
- "The resource has moved." print ;
+ "Location" swons unit
+ "301 Moved Permanently" response terpri ;
: header-line ( alist line -- alist )
": " split1 dup [ transp acons ] [ 2drop ] ifte ;
read-header dup "header" set
dup log-user-agent
read-post-request "response" set ;
-
-: with-request ( url quot -- )
- #! The quotation is called with the URL on the stack.
- [ swap prepare-url swap prepare-header call ] with-scope ;
USE: errors
USE: httpd-responder
USE: kernel
+USE: lists
USE: logging
USE: logic
USE: namespaces
drop "stdio" get
] ifte ;
-: bad-request ( -- )
- "400 Bad request" httpd-error ;
-
: url>path ( uri -- path )
url-decode dup "http://" str-head? dup [
"/" split1 f "" replace nip nip
: secure-path ( path -- path )
".." over str-contains? [ drop f ] when ;
-: get-request ( url -- )
- [ "get" swap serve-responder ] with-request ;
-
-: post-request ( url -- )
- [ "post" swap serve-responder ] with-request ;
+: request-method ( cmd -- method )
+ [
+ [ "GET" | "get" ]
+ [ "POST" | "post" ]
+ [ "HEAD" | "head" ]
+ ] assoc [ "bad" ] unless* ;
-: head-request ( url -- )
- [ "head" swap serve-responder ] with-request ;
+: (handle-request) ( arg cmd -- url method )
+ request-method dup "method" set swap
+ prepare-url prepare-header ;
: handle-request ( arg cmd -- )
- [
- [ "GET" = ] [ drop get-request ]
- [ "POST" = ] [ drop post-request ]
- [ "HEAD" = ] [ drop head-request ]
- [ drop t ] [ 2drop bad-request ]
- ] cond ;
+ [ (handle-request) serve-responder ] with-scope ;
: parse-request ( request -- )
dup log
! Responders are called in a new namespace with these
! variables:
+! - method -- one of get, post, or head.
! - request -- the entire URL requested, including responder
! name
! - raw-query -- raw query string
[
drop "HEAD method not implemented" httpd-error
] "head" set
+ ( url -- )
+ [
+ drop bad-request
+ ] "bad" set
] extend ;
: get-responder ( name -- responder )
<file> swap <file>
[ "java.io.File" ] "java.io.File" "renameTo"
jinvoke ;
+
+: file-length ( file -- size )
+ <file> [ ] "java.io.File" "length" jinvoke ;
: directory ( dir -- list )
#! List a directory.
(directory) str-sort ;
+
+: file-length ( file -- length )
+ stat dup [ cdr cdr car ] when ;
IN: telnetd
USE: combinators
-USE: continuations
USE: errors
USE: interpreter
+USE: kernel
USE: logging
USE: logic
USE: namespaces
USE: stack
USE: stdio
USE: streams
+USE: threads
: telnet-client ( socket -- )
dup [
interpreter-loop
] with-stream ;
+: telnet-connection ( socket -- )
+ #! We don't do multitasking in JFactor.
+ java? [
+ telnet-client
+ ] [
+ [ telnet-client ] in-thread drop
+ ] ifte ;
+
: quit-flag ( -- ? )
global [ "telnetd-quit-flag" get ] bind ;
[
quit-flag not
] [
- dup >r accept telnet-client r>
+ dup >r accept telnet-connection r>
] while ;
: telnetd ( port -- )
USE: stdio
USE: test
USE: url-encoding
+USE: strings
+USE: stack
+USE: lists
-[ "HTTP/1.0 404\nContent-Type: text/html\n" ]
-[ "404" "text/html" response ] unit-test
+[ "HTTP/1.0 200 OK\nContent-Length: 12\nContent-Type: text/html\n" ]
+[
+ [ "text/html" 12 file-response ] with-string
+] unit-test
[ 5430 ]
[ f "Content-Length: 5430" header-line content-length ] unit-test
projects / factor.git / commitdiff