file responder directory listing

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index ef3e2092be9a001c28f702eefe6e41c52e77f00b..841f62c1ba9face812692f10fbebf1d5c123c2d1 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,8 +1,6 @@
 - alist -vs- assoc terminology\r
 - some way to run httpd from command line\r
 - 'default responder' for when we go to root\r
-- file responder:\r
-  - directory listings\r
 - minimize stage2 initialization code, just move it to source files\r
 \r
 + bignums:\r
@@ -83,6 +81,10 @@
 \r
 + misc:\r
 \r
+- directory listings:\r
+  - icons for file responder\r
+  - cwd, cd, pwd, dir., pwd. words\r
+- -1.1 3 ^ shouldn't give a complex number\r
 - don't rehash strings on every startup\r
 - 'cascading' styles\r
 - jedit ==> jedit-word, jedit takes a file name\r

diff --git a/build.xml b/build.xml
index 0fdd9b1c2ea195044ed1e3256b6b4aaf4523126a..f2e4ff27102ff9831b151a4501eeba4816f67e26 100644 (file)
--- a/build.xml
+++ b/build.xml
@@ -52,6 +52,7 @@
                                <include name="*.xml"/>
                                <include name="library/**/*.factor"/>
                                <include name="library/**/*.txt"/>
+                               <include name="library/**/*.png"/>
                                <include name="org/**/*.class"/>
                                <include name="*.factor"/>
                                <include name="doc/**/*.html"/>

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index a4f6bafc3cc2b963d9b2a37791ab9fcb6fcfe26f..573f20eb7088b279a31dd372847f887e8311eaf8 100644 (file)
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -59,7 +59,7 @@ DEFER: sbuf-clone
 
 IN: files
 DEFER: stat
-DEFER: directory
+DEFER: (directory)
 
 IN: io-internals
 DEFER: port?
@@ -223,7 +223,7 @@ IN: cross-compiler
         setenv
         open-file
         stat
-        read-dir
+        (directory)
         garbage-collection
         save-image
         datastack

diff --git a/library/files.factor b/library/files.factor
index 73f7f607fbdab47d95746fd7968a6a9ea84e2d60..3560bcee3c4196cccf9ba234113cab140d2a8648 100644 (file)
--- a/library/files.factor
+++ b/library/files.factor
@@ -28,8 +28,10 @@
 IN: files
 USE: combinators
 USE: lists
+USE: logic
 USE: namespaces
 USE: stack
+USE: stdio
 USE: strings
 
 : set-mime-types ( assoc -- )
@@ -44,6 +46,32 @@ USE: strings
 : mime-type ( filename -- mime-type )
     file-extension mime-types assoc [ "text/plain" ] unless* ;
 
+: dir-icon
+    "/library/icons/Folder.png" ;
+
+: file-icon
+    "/library/icons/File.png" ;
+
+: file-icon. ( path -- )
+    directory? dir-icon file-icon ? write-icon ;
+
+: file-link. ( dir name -- )
+    tuck "/" swap cat3 "file-link" swons unit write-attr ;
+
+: file. ( dir name -- )
+    #! If "doc-root" set, create links relative to it.
+    2dup "/" swap cat3 file-icon. " " write file-link. terpri ;
+
+: directory. ( dir -- )
+    #! If "doc-root" set, create links relative to it.
+    dup directory [
+        dup [ "." ".." ] contains? [
+            drop
+        ] [
+            dupd file.
+        ] ifte
+    ] each drop ;
+
 [
     [ "html"   | "text/html"                        ]
     [ "txt"    | "text/plain"                       ]

diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor
index 51448fc85299cb406bfa4cd40efc32d4220ba6ea..4579d597a0eb42f8d8d63f0738c5fa8e20d8caa2 100644 (file)
--- a/library/httpd/file-responder.factor
+++ b/library/httpd/file-responder.factor
@@ -29,6 +29,7 @@ IN: file-responder
 USE: combinators
 USE: errors
 USE: files
+USE: html
 USE: httpd
 USE: httpd-responder
 USE: kernel
@@ -64,17 +65,18 @@ USE: strings
     "raw-query" get [ CHAR: ? % % ] when*
     %> redirect ;
 
+: list-directory ( directory -- )
+    serving-html dup [ directory. ] simple-html-document ;
+
 : serve-directory ( filename -- )
-    dup "/" str-tail? dup [
-        drop dup "index.html" cat2 dup exists? [
+    "/" ?str-tail [
+        dup "index.html" cat2 dup exists? [
             serve-file
         ] [
-            drop
-            "Foo bar" log
-            drop
+            drop list-directory
         ] ifte
     ] [
-        2drop directory-no/
+        drop directory-no/
     ] ifte ;
 
 : serve-object ( filename -- )

diff --git a/library/httpd/html.factor b/library/httpd/html.factor
index f7d4037a1d0ae2f18723d5cd15882bfb93dae7f1..1bb85f1878053b4c223ffea2e56af3a64d7b90b0 100644 (file)
--- a/library/httpd/html.factor
+++ b/library/httpd/html.factor
@@ -65,12 +65,6 @@ USE: url-encoding
     #! Wrap a string in an HTML tag.
     <% dupd opening-tag swap % closing-tag %> ;
 
-: link-attrs ( link -- attrs )
-    <% "href=\"/inspect/" % % "\"" % %> ;
-
-: link-tag ( string link -- string )
-    url-encode "a" swap link-attrs html-tag ;
-
 : >hex-color ( triplet -- hex )
     [ >hex 2 digits ] map "#" swons cat ;
 
@@ -105,8 +99,28 @@ USE: url-encoding
 : span-tag ( string style -- string )
     "span" swap <% "style=\"" % css-style% "\"" % %> html-tag ;
 
+: link-tag ( string link -- string )
+    url-encode "a" swap <% "href=" % unparse % %> html-tag ;
+
+: resolve-file-link ( path -- link )
+    #! The file responder needs relative links not absolute
+    #! links.
+    "doc-root" get [
+        ?str-head [ "/" ?str-head drop ] when
+    ] when* "/" ?str-tail drop ;
+
+: file-link-href ( path -- href )
+    <% "/file/" % resolve-file-link % %> ;
+
+: object-link-href ( path -- href )
+    <% "/inspect/" % % %> ;
+
 : html-attr-string ( string style -- string )
-    [ span-tag ] keep "link" swap assoc [ link-tag ] when* ;
+    [ span-tag ] keep
+    [
+        [ "file-link"   file-link-href   link-tag ]
+        [ "object-link" object-link-href link-tag ]
+    ] assoc-apply ;
 
 : html-write-attr ( string style -- )
     swap chars>entities swap html-attr-string write ;
@@ -151,5 +165,5 @@ USE: url-encoding
 
 : simple-html-document ( title quot -- )
     swap [
-        [ [ call ] with-html-stream ] preformatted-html
+        [ with-html-stream ] preformatted-html
     ] html-document ;

diff --git a/library/httpd/responder.factor b/library/httpd/responder.factor
index 1fee1ee99507547d2fcc69b282f00ab743f5c685..768bd4efa45fc63fa26a207f745eca703e207b4e 100644 (file)
--- a/library/httpd/responder.factor
+++ b/library/httpd/responder.factor
@@ -75,7 +75,7 @@ USE: strings
 
 : trim-/ ( url -- url )
     #! Trim a leading /, if there is one.
-    dup "/" str-head? dup [ nip ] [ drop ] ifte ;
+    "/" ?str-head drop ;
 
 : log-responder ( url -- )
     "Calling responder " swap cat2 log ;

diff --git a/library/icons/File.png b/library/icons/File.png
new file mode 100644 (file)
index 0000000..dd1124b
Binary files /dev/null and b/library/icons/File.png differ

diff --git a/library/icons/Folder.png b/library/icons/Folder.png
new file mode 100644 (file)
index 0000000..2de866a
Binary files /dev/null and b/library/icons/Folder.png differ

diff --git a/library/inspector.factor b/library/inspector.factor
index 11678258dee2d2e09c868108b2f6d9ba12520c51..229b6f15509a4b160bcbbaebf025c49ee93abc1c 100644 (file)
--- a/library/inspector.factor
+++ b/library/inspector.factor
@@ -49,7 +49,8 @@ USE: vectors
     vars [ print ] each ;
 
 : link-style ( path -- style )
-    relative>absolute-object-path "link" default-style acons ;
+    relative>absolute-object-path
+    "object-link" default-style acons ;
 
 : var. ( [ name | value ] -- )
     uncons unparse swap link-style write-attr ;

diff --git a/library/platform/jvm/boot-sumo.factor b/library/platform/jvm/boot-sumo.factor
index 532061a92b86160924f69b81a503868304217cb9..a926b8f48dafff3107de15f7e8d2aed19ec3218f 100644 (file)
--- a/library/platform/jvm/boot-sumo.factor
+++ b/library/platform/jvm/boot-sumo.factor
@@ -68,7 +68,6 @@ USE: parser
 "/library/stream.factor"                    run-resource ! streams
 "/library/platform/jvm/stream.factor"       run-resource ! streams
 "/library/platform/jvm/files.factor"        run-resource ! files
-"/library/files.factor"                     run-resource ! files
 "/library/stdio.factor"                     run-resource ! stdio
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser
@@ -91,6 +90,7 @@ USE: parser
 "/library/stdio-binary.factor"             run-resource ! stdio
 "/library/vocabulary-style.factor"         run-resource ! style
 "/library/prettyprint.factor"              run-resource ! prettyprint
+"/library/files.factor"                    run-resource ! files
 "/library/platform/jvm/prettyprint.factor" run-resource ! prettyprint
 "/library/interpreter.factor"              run-resource ! interpreter
 "/library/inspector.factor"                run-resource ! inspector

diff --git a/library/platform/jvm/kernel.factor b/library/platform/jvm/kernel.factor
index b8b0dccb731d747fbefd728cdb894ceb6043d550..b1b462c1b92a5e2297808598f8b4c9877a618a69 100644 (file)
--- a/library/platform/jvm/kernel.factor
+++ b/library/platform/jvm/kernel.factor
@@ -56,9 +56,11 @@ IN: kernel
     [ "java.lang.Object" "java.lang.Object" ]
     "factor.FactorLib" "equal" jinvoke-static ;
 
+: class-of* ( obj -- class )
+    [ ] "java.lang.Object" "getClass" jinvoke ;
+
 : class-of ( obj -- class )
-    [ ] "java.lang.Object" "getClass" jinvoke
-    [ ] "java.lang.Class" "getName" jinvoke ;
+    class-of* [ ] "java.lang.Class" "getName" jinvoke ;
 
 : is ( obj class -- boolean )
     ! Like "instanceof" in Java.
@@ -115,3 +117,8 @@ IN: kernel
   >bignum ;
 
 : room free-memory total-memory ;
+
+: resource ( path -- url )
+    interpreter class-of*
+    [ "java.lang.String" ]
+    "java.lang.Class" "getResource" jinvoke ;

diff --git a/library/platform/jvm/listener.factor b/library/platform/jvm/listener.factor
index 25d3c1789d87680efcc472ecdde047d29bdaf009..0df831f1f2e504468c8dc9fa5a7864d054dfab8e 100644 (file)
--- a/library/platform/jvm/listener.factor
+++ b/library/platform/jvm/listener.factor
@@ -55,6 +55,18 @@ USE: unparser
     "javax.swing.text.StyleConstants" swap jvar-static-get
     ; inline
 
+: set-icon-style ( attribute-set icon -- )
+    [
+        "javax.swing.text.MutableAttributeSet"
+        "javax.swing.Icon"
+    ] "javax.swing.text.StyleConstants"
+    "setIcon" jinvoke-static ;
+
+: <icon> ( resource -- icon )
+    resource
+    [ "java.net.URL" ]
+    "javax.swing.ImageIcon" jnew ;
+
 : swing-attribute+ ( attribute-set value key -- )
     style-constant attribute+ ;
 
@@ -68,38 +80,57 @@ USE: unparser
     "factor.listener.FactorListener" "Actions" jvar-static-get
     ; inline
 
-: actions ( -- list )
+: <action-menu-item> ( path pair -- pair )
+    uncons >r " " swap cat3 r> cons ;
+
+: <actions-menu> ( path actions -- alist )
+    [ dupd <action-menu-item> ] map nip ;
+
+: object-actions ( -- list )
     [
-        [ "describe-path" | "Describe" ]
-        [ "lookup" | "Push" ]
+        [ "describe-path"  | "Describe" ]
+        [ "lookup"         | "Push" ]
         [ "lookup execute" | "Execute" ]
-        [ "lookup jedit" | "jEdit" ]
+        [ "lookup jedit"   | "jEdit" ]
         [ "lookup usages." | "Usages" ]
     ] ;
 
-: <action-menu-item> ( path pair -- pair )
-    uncons >r " " swap cat3 r> cons ;
+: <object-actions-menu> ( path -- alist )
+    unparse object-actions <actions-menu> ;
 
-: <actions-menu> ( path -- alist )
-    unparse actions [ dupd <action-menu-item> ] map nip ;
+: file-actions ( -- list )
+    [
+        [ ""               | "Push" ]
+        [ "run-file"       | "Run file" ]
+        [ "directory."     | "List directory" ]
+    ] ;
+
+: <file-actions-menu> ( path -- alist )
+    unparse file-actions <actions-menu> ;
 
 : underline-attribute ( attribute-set -- )
     t "Underline" swing-attribute+ ;
 
-: link-attribute ( attribute-set target -- )
+: object-link-attribute ( attribute-set target -- )
+    over underline-attribute
+    <object-actions-menu> actions-key attribute+ ;
+
+: file-link-attribute ( attribute-set target -- )
     over underline-attribute
-    <actions-menu> actions-key attribute+ ;
+    <file-actions-menu> actions-key attribute+ ;
 
 : style>attribute-set ( style -- attribute-set )
     <attribute-set> swap [
-        [ "link"      dupd link-attribute ]
-        [ "bold"      drop dup t "Bold" swing-attribute+ ]
-        [ "italics"   drop dup t "Italic" swing-attribute+ ]
-        [ "underline" drop dup t "Underline" swing-attribute+ ]
-        [ "fg"        dupd >color "Foreground" swing-attribute+ ]
-        [ "bg"        dupd >color "Background" swing-attribute+ ]
-        [ "font"      dupd "FontFamily" swing-attribute+ ]
-        [ "size"      dupd "FontSize" swing-attribute+ ]
+        [ "object-link" dupd object-link-attribute ]
+        [ "file-link"   dupd file-link-attribute ]
+        [ "bold"        drop dup t "Bold" swing-attribute+ ]
+        [ "italics"     drop dup t "Italic" swing-attribute+ ]
+        [ "underline"   drop dup t "Underline" swing-attribute+ ]
+        [ "fg"          dupd >color "Foreground" swing-attribute+ ]
+        [ "bg"          dupd >color "Background" swing-attribute+ ]
+        [ "font"        dupd "FontFamily" swing-attribute+ ]
+        [ "size"        dupd "FontSize" swing-attribute+ ]
+        [ "icon"        dupd <icon> set-icon-style ]
     ] assoc-apply ;
 
 : set-character-attrs ( attrs -- )

diff --git a/library/platform/native/files.factor b/library/platform/native/files.factor
index 4ebf34b3199d1cbe13a111b031071e1991dc2411..9d8defbec8818eee826e44fed11fa2613863c791 100644 (file)
--- a/library/platform/native/files.factor
+++ b/library/platform/native/files.factor
@@ -27,12 +27,18 @@
 
 IN: files
 USE: combinators
+USE: io-internals
 USE: lists
 USE: logic
 USE: stack
+USE: strings
 
 : exists? ( file -- ? )
     stat >boolean ;
 
 : directory? ( file -- ? )
     stat dup [ car ] when ;
+
+: directory ( dir -- list )
+    #! List a directory.
+    (directory) str-sort ;

diff --git a/library/prettyprint.factor b/library/prettyprint.factor
index a69c7fde61399829160d8e9d6c49ee609d2dc166..99e6696211177524bf6a4c893e4de4d715d9d609 100644 (file)
--- a/library/prettyprint.factor
+++ b/library/prettyprint.factor
@@ -153,7 +153,7 @@ DEFER: prettyprint*
 
 : word-attrs ( word -- attrs )
     dup defined? [
-        dup >r word-link "link" r> word-style acons
+        dup >r word-link "object-link" r> word-style acons
     ] [
         word-style
     ] ifte ;
@@ -181,7 +181,7 @@ DEFER: prettyprint*
     <% "vocabularies'" % % %> ;
 
 : vocab-attrs ( word -- attrs )
-    vocab-link "link" default-style acons ;
+    vocab-link "object-link" default-style acons ;
 
 : prettyprint-vocab ( vocab -- )
     dup vocab-attrs write-attr ;

diff --git a/library/stdio.factor b/library/stdio.factor
index cb4c273117e9fc2f508ab98867fcfdfeb967c146..8b358a60adf041377f0abe2c7d451ae07bf21bec 100644 (file)
--- a/library/stdio.factor
+++ b/library/stdio.factor
@@ -29,6 +29,7 @@ IN: stdio
 USE: combinators
 USE: errors
 USE: kernel
+USE: lists
 USE: namespaces
 USE: stack
 USE: streams
@@ -66,6 +67,10 @@ USE: streams
     #! Write an attributed string to standard output.
     "stdio" get fwrite-attr ;
 
+: write-icon ( resource -- )
+    #! Write an icon. Eg, /library/icons/File.png
+    "icon" swons unit "" swap write-attr ;
+
 : print ( string -- )
     "stdio" get fprint ;
 

diff --git a/library/strings.factor b/library/strings.factor
index 836c1e386a19611bc4e5aada60822c2467aa6439..150a35915cf54d1133f134833cb2eff1c9c25b2e 100644 (file)
--- a/library/strings.factor
+++ b/library/strings.factor
@@ -104,6 +104,9 @@ USE: stack
         [ = ] dip f ?
     ] ifte ;
 
+: ?str-head ( str begin -- str ? )
+    dupd str-head? dup [ nip t ] [ drop f ] ifte ;
+
 : str-tailcut ( str end -- str str )
     str-length [ dup str-length ] dip - str/ ;
 
@@ -117,6 +120,9 @@ USE: stack
         [ = ] dip f ?
     ] ifte ;
 
+: ?str-tail ( str end -- str ? )
+    dupd str-tail? dup [ nip t ] [ drop f ] ifte ;
+
 : split1 ( string split -- before after )
     #! The car of the pair is the string up to the first
     #! occurrence of split; the cdr is the remainder of

diff --git a/library/test/httpd/html.factor b/library/test/httpd/html.factor
index c538a4397a036f40bf3dc31ac79607b6550430c9..f19d15f71eb523c11ce847be50634ddbdc2e4dcf 100644 (file)
--- a/library/test/httpd/html.factor
+++ b/library/test/httpd/html.factor
@@ -16,3 +16,11 @@ USE: test
     [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ]
     span-tag
 ] unit-test
+
+[ "/file/foo/bar" ]
+[
+    [
+        "/home/slava/doc/" "doc-root" set
+        "/home/slava/doc/foo/bar" file-link-href
+    ] with-scope
+] unit-test

diff --git a/library/vocabularies.factor b/library/vocabularies.factor
index db0ba4c93b68f0bfdcc427234a757af5548f28c8..2bc9f2fc5d864de48ffeae84c0202669f6b75703 100644 (file)
--- a/library/vocabularies.factor
+++ b/library/vocabularies.factor
@@ -77,8 +77,9 @@ USE: strings
         "combinators"
         "compiler"
         "continuations"
-        "errors"
         "debugger"
+        "errors"
+        "files"
         "hashtables"
         "inferior"
         "inspector"