slightly more modular loading of subsystems

TODO.FACTOR.txt

@@ -7,7 +7,6 @@
 <magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup
 
 - single-stepper and variable access: wrong namespace?
-- [ over ] generics no-method
 - investigate if COPYING_GEN needs a fix
 - faster layout
 - add a socket timeout

library/bootstrap/boot-stage3.factor

@@ -73,63 +73,9 @@ t [
     "/library/tools/jedit-wire.factor"
     "/library/tools/jedit.factor"
 
-    "/library/httpd/http-common.factor"
+    "/library/httpd/load.factor"
-    "/library/httpd/mime.factor"
+    "/library/sdl/load.factor"
-    "/library/httpd/html-tags.factor"
+    "/library/ui/load.factor"
-    "/library/httpd/html.factor"
-    "/library/httpd/responder.factor"
-    "/library/httpd/httpd.factor"
-    "/library/httpd/file-responder.factor"
-    "/library/httpd/test-responder.factor"
-    "/library/httpd/resource-responder.factor"
-    "/library/httpd/cont-responder.factor"
-    "/library/httpd/browser-responder.factor"
-    "/library/httpd/default-responders.factor"
-    "/library/httpd/http-client.factor"
-
-    "/library/sdl/sdl.factor"
-    "/library/sdl/sdl-video.factor"
-    "/library/sdl/sdl-event.factor"
-    "/library/sdl/sdl-gfx.factor"
-    "/library/sdl/sdl-keysym.factor"
-    "/library/sdl/sdl-keyboard.factor"
-    "/library/sdl/sdl-ttf.factor"
-    "/library/sdl/sdl-utils.factor"
-
-    "/library/ui/shapes.factor"
-    "/library/ui/points.factor"
-    "/library/ui/rectangles.factor"
-    "/library/ui/lines.factor"
-    "/library/ui/ellipses.factor"
-    "/library/ui/gadgets.factor"
-    "/library/ui/hierarchy.factor"
-    "/library/ui/paint.factor"
-    "/library/ui/text.factor"
-    "/library/ui/gestures.factor"
-    "/library/ui/hand.factor"
-    "/library/ui/layouts.factor"
-    "/library/ui/piles.factor"
-    "/library/ui/shelves.factor"
-    "/library/ui/borders.factor"
-    "/library/ui/stacks.factor"
-    "/library/ui/frames.factor"
-    "/library/ui/world.factor"
-    "/library/ui/labels.factor"
-    "/library/ui/buttons.factor"
-    "/library/ui/checkboxes.factor"
-    "/library/ui/line-editor.factor"
-    "/library/ui/events.factor"
-    "/library/ui/scrolling.factor"
-    "/library/ui/editors.factor"
-    "/library/ui/menus.factor"
-    "/library/ui/presentations.factor"
-    "/library/ui/tiles.factor"
-    "/library/ui/panes.factor"
-    "/library/ui/dialogs.factor"
-    "/library/ui/inspector.factor"
-    "/library/ui/init-world.factor"
-    "/library/ui/tool-menus.factor"
-    "/library/ui/ui.factor"
 ] pull-in
 
 compile? [

library/errors.factor

@@ -10,7 +10,7 @@ TUPLE: no-method object generic ;
 : no-method ( object generic -- )
     #! We 2dup here to leave both values on the stack, for
     #! post-mortem inspection.
-    2dup <no-method> throw ;
+    <no-method> throw ;
 
 ! This is a very lightweight exception handling system.
 

library/generic/generic.factor

@@ -64,7 +64,7 @@ math-internals ;
 : dispatcher% "dispatcher" word-prop % ;
 
 : error-method ( generic -- method )
-    [ literal, \ no-method , ] make-list ;
+    [ dup picker% literal, \ no-method , ] make-list ;
 
 : empty-method ( generic -- method )
     dup "picker" word-prop [ dup ] = [

library/httpd/default-responders.factor

@@ -7,7 +7,8 @@ test-responder ;
 
 #! Remove all existing responders, and create a blank
 #! responder table.
-global [ <namespace> "httpd-responders" set ] bind
+global [
+    <namespace> "httpd-responders" set
 
     ! Runs all unit tests and dumps result to the client. This uses
     ! a lot of server resources, so disable it on a busy server.
@@ -44,3 +45,8 @@ global [ <namespace> "httpd-responders" set ] bind
     
     ! The root directory is served by...
     "file" set-default-responder
+
+    "httpd-vhosts" nest [
+        <namespace> "default" set
+    ] bind
+] bind

library/httpd/httpd.factor

@@ -26,12 +26,16 @@ stdio streams strings threads http sequences ;
         [[ "HEAD" "head" ]]
     ] assoc [ "bad" ] unless* ;
 
-: (handle-request) ( arg cmd -- url method )
+: (handle-request) ( arg cmd -- method path )
     request-method dup "method" set swap
     prepare-url prepare-header ;
 
 : handle-request ( arg cmd -- )
-    [ (handle-request) serve-responder ] with-scope ;
+    [
+        (handle-request)
+        "Host" "header" get assoc
+        serve-responder
+    ] with-scope ;
 
 : parse-request ( request -- )
     dup log
@@ -59,11 +63,8 @@ stdio streams strings threads http sequences ;
 
 : httpd ( port -- )
     <server> "http-server" set [
-        [
+        [ httpd-loop ]
-            httpd-loop
+        [ "http-server" get stream-close rethrow ] catch
-        ] [
-            "http-server" get stream-close rethrow
-        ] catch
     ] with-logging ;
 
 : stop-httpd ( -- )

library/httpd/load.factor

@@ -0,0 +1,18 @@
+USING: kernel parser sequences stdio ;
+[
+    "/library/httpd/http-common.factor"
+    "/library/httpd/mime.factor"
+    "/library/httpd/html-tags.factor"
+    "/library/httpd/html.factor"
+    "/library/httpd/responder.factor"
+    "/library/httpd/httpd.factor"
+    "/library/httpd/file-responder.factor"
+    "/library/httpd/test-responder.factor"
+    "/library/httpd/resource-responder.factor"
+    "/library/httpd/cont-responder.factor"
+    "/library/httpd/browser-responder.factor"
+    "/library/httpd/default-responders.factor"
+    "/library/httpd/http-client.factor"
+] [
+    dup print run-resource
+] each

library/httpd/responder.factor

@@ -111,16 +111,16 @@ stdio streams strings ;
         ] "bad" set
     ] extend ;
 
-: get-responder ( name -- responder )
+: vhost ( name -- responder )
+    "httpd-vhosts" get hash [ "default" vhost ] unless* ;
+
+: responder ( name -- responder )
     "httpd-responders" get hash [
         "404" "httpd-responders" get hash
     ] unless* ;
 
-: default-responder ( -- responder )
-    "default" get-responder ;
-
 : set-default-responder ( name -- )
-    get-responder "default" "httpd-responders" get set-hash ;
+    responder "default" "httpd-responders" get set-hash ;
 
 : responder-argument ( argument -- argument )
     dup empty? [ drop "default-argument" get ] when ;
@@ -129,9 +129,9 @@ stdio streams strings ;
     [ responder-argument swap get call ] bind ;
 
 : serve-default-responder ( method url -- )
-    default-responder call-responder ;
+    "default" responder call-responder ;
 
-: log-responder ( url -- )
+: log-responder ( path -- )
     "Calling responder " swap append log ;
 
 : trim-/ ( url -- url )
@@ -140,21 +140,23 @@ stdio streams strings ;
 
 : serve-explicit-responder ( method url -- )
     "/" split1 dup [
-        swap get-responder call-responder
+        swap responder call-responder
     ] [
         ! Just a responder name by itself
         drop "request" get "/" append redirect drop
     ] ifte ;
 
-: serve-responder ( method url -- )
+: serve-responder ( method path host -- )
-    #! Responder URLs come in two forms:
+    #! Responder paths come in two forms:
-    #! /foo/bar... - default-responder used
+    #! /foo/bar... - default responder used
     #! /responder/foo/bar - responder foo, argument bar
+    vhost [
         dup log-responder trim-/ "responder/" ?head [
             serve-explicit-responder
         ] [
             serve-default-responder
-    ] ifte ;
+        ] ifte
+    ] bind ;
 
 : no-such-responder ( -- )
     "404 No such responder" httpd-error ;

library/sdl/load.factor

@@ -0,0 +1,13 @@
+USING: kernel parser sequences stdio ;
+[
+    "/library/sdl/sdl.factor"
+    "/library/sdl/sdl-video.factor"
+    "/library/sdl/sdl-event.factor"
+    "/library/sdl/sdl-gfx.factor"
+    "/library/sdl/sdl-keysym.factor"
+    "/library/sdl/sdl-keyboard.factor"
+    "/library/sdl/sdl-ttf.factor"
+    "/library/sdl/sdl-utils.factor"
+] [
+    dup print run-resource
+] each

library/tools/debugger.factor

@@ -65,12 +65,9 @@ M: kernel-error error. ( error -- )
     } nth execute ;
 
 M: no-method error. ( error -- )
-    [
+    "No suitable method." print
-        "The generic word " ,
+    "Generic word: " write dup no-method-generic .
-        dup no-method-generic unparse ,
+    "Object: " write no-method-object . ;
-        " does not have a suitable method for " ,
-        no-method-object unparse ,
-    ] make-string print ;
 
 : parse-dump ( error -- )
     "Parsing " write

library/ui/load.factor

@@ -0,0 +1,39 @@
+USING: kernel parser sequences stdio ;
+[
+    "/library/ui/shapes.factor"
+    "/library/ui/points.factor"
+    "/library/ui/rectangles.factor"
+    "/library/ui/lines.factor"
+    "/library/ui/ellipses.factor"
+    "/library/ui/gadgets.factor"
+    "/library/ui/hierarchy.factor"
+    "/library/ui/paint.factor"
+    "/library/ui/text.factor"
+    "/library/ui/gestures.factor"
+    "/library/ui/hand.factor"
+    "/library/ui/layouts.factor"
+    "/library/ui/piles.factor"
+    "/library/ui/shelves.factor"
+    "/library/ui/borders.factor"
+    "/library/ui/stacks.factor"
+    "/library/ui/frames.factor"
+    "/library/ui/world.factor"
+    "/library/ui/labels.factor"
+    "/library/ui/buttons.factor"
+    "/library/ui/checkboxes.factor"
+    "/library/ui/line-editor.factor"
+    "/library/ui/events.factor"
+    "/library/ui/scrolling.factor"
+    "/library/ui/editors.factor"
+    "/library/ui/menus.factor"
+    "/library/ui/presentations.factor"
+    "/library/ui/tiles.factor"
+    "/library/ui/panes.factor"
+    "/library/ui/dialogs.factor"
+    "/library/ui/inspector.factor"
+    "/library/ui/init-world.factor"
+    "/library/ui/tool-menus.factor"
+    "/library/ui/ui.factor"
+] [
+    dup print run-resource
+] each