file-responder improvements, plugin improvements

TODO.FACTOR.txt

@@ -1,8 +1,7 @@
-- telnetd should use multitasking
-- file-responder: Content-Length
-- HEAD request for file-responder
-  - nicer way to combine two paths
-  - icons for file responder
+- TEST telnetd should use multitasking
+- quit responder breaks with multithreading
+- nicer way to combine two paths
+- icons for file responder
 - -1.1 3 ^ shouldn't give a complex number
 - don't show listener on certain commands
 - inferior hangs
@@ -19,6 +18,7 @@
 - introduce ifte* and ?str-head/?str-tail where appropriate
 - cwd, cd, pwd, dir., pwd. words
 - namespace clone drops static var bindings
+- f usages. --> don't print all words
 
 + bignums:
 
@@ -100,7 +100,6 @@
 + httpd:
 
 - 'default responder' for when we go to root
-- quit responder breaks with multithreading
 - wiki responder:
   - port to native
   - text styles

actions.xml

@@ -18,19 +18,22 @@
 			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">
@@ -55,10 +58,11 @@
 	</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>

factor/jedit/FactorPlugin.java

@@ -44,6 +44,13 @@ public class FactorPlugin extends EditPlugin
 
 	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.

library/httpd/default-responders.factor

@@ -68,6 +68,8 @@ USE: wiki-responder
         <responder> [
             "file" "responder" set
             [ file-responder ] "get" set
+            [ file-responder ] "post" set
+            [ file-responder ] "head" set
         ] extend "file" set
 
 !        <responder> [

library/httpd/file-responder.factor

@@ -33,6 +33,7 @@ USE: html
 USE: httpd
 USE: httpd-responder
 USE: kernel
+USE: lists
 USE: logging
 USE: namespaces
 USE: parser
@@ -40,18 +41,26 @@ USE: stack
 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" = [
@@ -66,7 +75,12 @@ USE: strings
     %> 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 [
@@ -82,13 +96,13 @@ USE: strings
 : 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 ;

library/httpd/http-common.factor

@@ -42,30 +42,42 @@ USE: unparser
 
 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 ;
+
+: error-head ( error -- )
+    dup log-error
+    [ [ "Content-Type" | "text/html" ] ] over response ;
 
 : httpd-error ( error -- )
-    dup log-error
-    <% dup "text/html" response % error-body % %> print ;
+    #! 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 ;
@@ -107,7 +119,3 @@ USE: url-encoding
     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 ;

library/httpd/httpd.factor

@@ -30,6 +30,7 @@ USE: combinators
 USE: errors
 USE: httpd-responder
 USE: kernel
+USE: lists
 USE: logging
 USE: logic
 USE: namespaces
@@ -48,9 +49,6 @@ USE: url-encoding
         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
@@ -61,22 +59,19 @@ USE: url-encoding
 : secure-path ( path -- path )
     ".." over str-contains? [ drop f ] when ;
 
-: get-request ( url -- )
-    [ "get" swap serve-responder ] with-request ;
+: request-method ( cmd -- method )
+    [
+        [ "GET" | "get" ]
+        [ "POST" | "post" ]
+        [ "HEAD" | "head" ]
+    ] assoc [ "bad" ] unless* ;
 
-: post-request ( url -- )
-    [ "post" swap serve-responder ] with-request ;
-
-: 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

library/httpd/responder.factor

@@ -41,6 +41,7 @@ USE: strings
 ! 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
@@ -64,6 +65,10 @@ USE: strings
         [
             drop "HEAD method not implemented" httpd-error
         ] "head" set
+        ( url -- )
+        [
+            drop bad-request
+        ] "bad" set
     ] extend ;
 
 : get-responder ( name -- responder )

library/platform/jvm/files.factor

@@ -57,3 +57,6 @@ USE: strings
     <file> swap <file>
     [ "java.io.File" ] "java.io.File" "renameTo"
     jinvoke ;
+
+: file-length ( file -- size )
+    <file> [ ] "java.io.File" "length" jinvoke ;

library/platform/native/files.factor

@@ -42,3 +42,6 @@ USE: strings
 : directory ( dir -- list )
     #! List a directory.
     (directory) str-sort ;
+
+: file-length ( file -- length )
+    stat dup [ cdr cdr car ] when ;

library/telnetd.factor

@@ -27,15 +27,16 @@
 
 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 [
@@ -45,6 +46,14 @@ USE: streams
         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 ;
 
@@ -55,7 +64,7 @@ USE: streams
     [
         quit-flag not
     ] [
-        dup >r accept telnet-client r>
+        dup >r accept telnet-connection r>
     ] while ;
 
 : telnetd ( port -- )

library/test/httpd/httpd.factor

@@ -7,9 +7,14 @@ USE: namespaces
 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