===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/httpd.sm1,v
retrieving revision 1.6
retrieving revision 1.19
diff -u -p -r1.6 -r1.19
--- OpenXM/src/kan96xx/Doc/httpd.sm1	2002/10/17 13:40:28	1.6
+++ OpenXM/src/kan96xx/Doc/httpd.sm1	2005/11/21 12:46:49	1.19
@@ -1,11 +1,31 @@
-%% $OpenXM: OpenXM/src/kan96xx/Doc/httpd.sm1,v 1.5 2001/09/20 05:57:40 takayama Exp $
+%% $OpenXM: OpenXM/src/kan96xx/Doc/httpd.sm1,v 1.18 2005/11/21 09:12:22 takayama Exp $
 %% common modules for httpd on sm1.
+% [(Strict) 1] system_variable  % for debugging.
 /Oxserver_history_variable (Oxserver_history_variable_) def
 /httpd.image.type  
   [(getenv) (OpenXM_PSTOIMG_TYPE)] extension
 def
 
+/httpd_sm1.cookie 
+ [(oxGenPass)] extension 
+def
+/httpd.set-cookie {
+  [(Set-Cookie: httpd_sm1=) httpd_sm1.cookie] cat 
+} def
 
+
+[(getenv) (OXWEB_DEBUG)] extension tag 0 eq {
+   /httpd.debug 0 def
+} {  
+   /httpd.debug 1 def
+} ifelse
+[(getenv) (OXWEB_TAKE_LOG)] extension tag 0 eq {
+   /httpd.take.log  0 def
+} {  
+   /httpd.take.log 1 def
+} ifelse
+
+
 /httpd_startserver {
    [(sm1.socket) (open) [httpd.port (localhost)]] extension 
    /httpd.server.fdAndPort set
@@ -27,7 +47,7 @@ def
 
 /sendln {
  /arg1 set
- [/in-sendln /mmm] pushVariables
+ [/in-sendln /mmm /i] pushVariables
  [ arg1 /mmm set
   mmm tag 5 eq {
     [mmm 10 (string) dc] cat /mmm set
@@ -37,7 +57,8 @@ def
   [(sm1.socket) (select) [httpd.server.fd 0 get 0]] extension {
     (Warning (sendln): your peer closed the connection. Do not send the data.) message
   } {
-    [(sm1.socket) (write) [httpd.server.fd 0 get mmm]] extension message
+    [(sm1.socket) (write) [httpd.server.fd 0 get mmm]] extension /i set
+     httpd.debug { i message } { } ifelse
   } ifelse
  ] pop
  popVariables
@@ -70,10 +91,12 @@ def
   /httpd.serial 0 def
   /httpd.history [ ] def
   /httpd.result.history [ 0 ] def
+  [(nobody)] extension pop
   {
     httpd_startserver ;
     httpd_action ;
     httpd_stopserver ;
+    httpd.take.log { (date) system  } { } ifelse
 %    (sleep 2) system 
     httpd.serial 1 add /httpd.serial set
   } loop    
@@ -120,6 +143,7 @@ def
    (HTTP/0.9 200 OK) sendln
    (Connection: close) sendln
    (Content-Type: text/html) sendln
+   httpd.set-cookie sendln
    0 sendln
 %%   (<FORM NAME="myFORM" METHOD="POST">) sendln
    result sendln
@@ -127,7 +151,11 @@ def
    %%(<img src="hoge.jpeg"> <img>) sendln %%test.  It does not work always?!
    %%(<a href="hoge.jpeg"> Pretty format </a>) sendln %%test. It works.
 
-   (<FORM NAME="myFORM">) sendln
+  [(getenv) (OXWEB_POST)] extension tag 0 eq {
+    (<FORM NAME="myFORM">) sendln  % use get
+  }{
+    (<FORM NAME="myFORM" METHOD="POST">) sendln
+  } ifelse
    (<INPUT TYPE=submit VALUE="submit">) sendln
    [(<textarea name=) httpd.textarea.name 
     ( rows=10 cols="80" wrap="soft"></textarea>)] cat sendln
@@ -269,27 +297,6 @@ def
  } ifelse
 
 
-%% Decompose into tokens separated by a space.
-%% (GET /hoge.jpeg ???) ---> [(GET) (/hoge.jpeg) (???)]
-/toTokensBySpace {
-  /arg1 set
-  [/in-toTokesBySpace /ss /ss2 /i] pushVariables
-  [
-    /ss arg1 def
-    ss 1 copy /ss set
-    ss (array) dc /ss2 set
-    0 1 ss2 length 1 sub {
-      /i set
-      ss2 i get 32 eq { %% equal to space
-        ss i (,) put
-      } {  } ifelse
-    } for
-    ss message
-    [ ss to_records pop] /arg1 set
-  ] pop
-  popVariables
-  arg1
-} def
 
 /askToSendFile {
   /arg1 set
@@ -318,29 +325,59 @@ def
   arg1
 } def
 
-%% remove GET /?msg=
+%% remove GET /?msg= or msg=
 /removeGET {
   /arg1 set
   [/in-removeGET /s /s2 /i /j /i0
-   /tname
+   /tname  /nnn /sta
   ] pushVariables
   [
      /s arg1 def
-     /httpd.textarea.valid 1 def
+     /httpd.textarea.valid 0 def
      s 1 copy /s2 set
      s (array) dc /s set
 
+     /sta 0 def
+
+     %% In case of POST, remove the HTTP header. cf. trouble for NS 6.0
+     s length 4 gt {
+       [s 0 get s 1 get s 2 get s 3 get] (POST) (array) dc eq {
+          0 1 s length 4 sub { 
+             /i0 set
+             /sta i0 def
+             [ s i0 get  s i0 1 add get ] [ 10 10 ] eq 
+             [ s i0 get  s i0 1 add get s i0 2 add get s i0 3 add get] 
+             [ 13 10 13 10] eq or
+             { exit } { } ifelse
+          } for
+        }{ } ifelse
+     } { } ifelse
+     (sta=) messagen sta message 
+     /nnn httpd.textarea.name.aaa length 6 sub def
+
      /tname  [  ] def
-     0 1 s length 1 sub {
+     sta 1 s length 1 sub {
        /i0 set
        s i0 get 61 eq {  %% 61 is = 
          i0 1 add /i0 set
-         tname message
-         httpd.textarea.name.aaa message
+
+         [
+          << tname length 1 sub  >> -1
+          << tname length nnn sub >> dup 0 ge { } { pop 0 } ifelse 
+          {
+             /i set
+             tname i get
+          } for
+         ] reverse /tname set 
+         (GET /?) (array) dc tname join /tname set
+
+         httpd.debug { httpd.textarea.name.aaa message } {  } ifelse
          tname httpd.textarea.name.aaa eq {
            /httpd.textarea.valid 1 def
          } {
            /httpd.textarea.valid 0 def
+           tname message 
+           httpd.textarea.name.aaa { (string) dc } map cat message
            (Warning: got an invalid name for the text field.) message
          } ifelse
          exit
@@ -352,6 +389,8 @@ def
      i0 1 s length 1 sub {
        /i set
        s2 j << s i get (string) dc >> put
+       j s2 length 1 sub lt { s2 j 1 add ( ) put } { } ifelse
+       %% might cause a BUG. It should be improved.
        j 1 add /j set
      } for
      /arg1 s2 def
@@ -404,6 +443,7 @@ def
   [/in-preformatHTML /sss /c] pushVariables
   [
      /sss arg1 def
+     sss toString /sss set
      sss (array) dc /sss set
      sss {
        /c set
@@ -498,4 +538,314 @@ def
    ] pop
    popVariables
    arg1
+} def
+
+% This function will be written in C in a future.
+% [(httpd) (parseHTTP) string] extension
+% [(GET) key-value-pair-1 key-value-pair-2 ...]
+% [(POST) key-value-pair-1 key-value-pair-2 ...]
+% [(GET-file) file-1 file2 ...]
+% ex. (GET / HTT..) (GET /?rpc=1-2) 
+/httpd.parse {
+ /arg1 set 
+ [/in-httpd.parse /s /s2 /sta /i0
+  /ans /getKeyword /j /tname /tvalue
+ ] pushVariables
+ [
+     /s arg1 def
+     s 1 copy /s2 set
+     s (array) dc /s set
+
+     /sta 0 def
+     /getKeyword 0 def
+
+     s length 7 lt {
+        /ans [(GET-file)] def
+        /httpd.exit goto        
+     }{ } ifelse
+
+     /ans [(GET)] def
+     [s 0 get s 1 get s 2 get s 3 get s 4 get s 5 get] (GET /?) (array) dc eq {
+        /sta 6 def
+        /getKeyword 1 def
+     }{
+        [s 0 get s 1 get s 2 get s 3 get s 4 get] (GET /) (array) dc eq {
+            /sta 5 def
+        }{
+          [s 0 get s 1 get s 2 get s 3 get] (GET ) (array) dc eq {
+             /ans [(GET-file)] def 
+             /httpd.exit goto        
+          }  { /ans [ ] def /httpd.exit.goto } ifelse
+        } ifelse
+     }ifelse  
+
+     %% In case of POST, remove the HTTP header. cf. trouble for NS 6.0
+     [s 0 get s 1 get s 2 get s 3 get] (POST) (array) dc eq {
+          /ans [(POST) ] def
+          /getKeyword  1 def
+          0 1 s length 4 sub { 
+             /i0 set
+             /sta i0 def
+             [ s i0 get  s i0 1 add get ] [ 10 10 ] eq 
+             [ s i0 get  s i0 1 add get s i0 2 add get s i0 3 add get] 
+             [ 13 10 13 10] eq or
+             { exit } { } ifelse
+          } for
+     }{ } ifelse
+     (sta=) messagen sta message 
+
+     %% get file name
+     getKeyword not {
+       /tname  [  ] def
+       sta 1 << s length 1 sub >> {
+         /i0 set
+         s i0 get 32 le {  %% 32 is  " "
+           exit
+         } { } ifelse
+         tname s i0 get append /tname set
+       } for 
+       httpd.debug { (Filename is ) messagen tname {(string) dc } map message} {  } ifelse
+       /ans [(GET-file) tname { (string) dc } map cat ] def
+       /httpd.exit goto 
+     } { } ifelse
+
+     /tname  [  ] def
+     sta 1 << s length 1 sub >> {
+       /i0 set
+       s i0 get 61 eq {  %% 61 is = 
+         httpd.debug { tname message tname {(string) dc } map cat message} {  } ifelse
+         i0 1 add /i0 set
+         exit
+       } { } ifelse
+       tname s i0 get append /tname set
+     } for 
+
+     %% Remove space and cr/lf from the key word.
+     [
+       0 1 tname length 1 sub {
+         /j set
+         tname j get 36 le {
+         } {
+           tname j get 
+         } ifelse
+      } for
+     ] /tname set
+
+     /j 0 def
+     i0 1 s length 1 sub {
+       /i set
+       s2 j << s i get (string) dc >> put
+       j s2 length 1 sub lt { s2 j 1 add ( ) put } { } ifelse
+       %% might cause a BUG. It should be improved.
+       j 1 add /j set
+     } for
+     ans [tname {(string) dc} map  cat
+           s2 webstringToAscii ] append
+     /ans set
+
+     /httpd.exit
+     ans length 1 lt {
+       /ans [(Unknown)] def
+     } {  } ifelse
+     /arg1 ans def
+ ] pop
+ popVariables
+ arg1
+} def
+
+/httpd.root [(getenv) (OXWEB_HTTPD_ROOT)] extension def
+%% /usr/local/www/data/   Assume slash!!
+
+% [(GET-file) (filename)] httpd_sendfile
+% [(MSG) (message)]       httpd_sendfile
+/httpd_sendfile {
+  /arg1 set
+  [/in-htpd_sendfile /msg /fname /fname2
+   /fsize
+  ] pushVariables
+  [
+     /msg arg1 def
+     %% Send message.  [(MSG) msg2 ...] httpd_sendfile
+     msg message
+     msg 0 get (MSG) eq {
+       (HTTP/0.9 200 OK) sendln
+       (Connection: close) sendln
+       (Content-Type: text/html) sendln
+       0 sendln
+       msg rest { sendln } map
+       0 sendln
+       [(flush)] extension
+       /httpd_sendfile.L1 goto
+     }{ } ifelse
+     %% Get a file message.  [(GET-file) fname] httpd_sendfile
+     msg 0 get (GET-file) eq {
+       httpd.root tag 5 eq not {
+         [(MSG) (<h1> File transfer is not allowed on this server. </h1>)]
+         httpd_sendfile
+         /httpd_sendfile.L1 /httpd_sendfile.L1 goto
+       } {  } ifelse
+       msg length 1 eq {
+           /fname (index.html) def
+       }{  
+           /fname msg 1 get def
+           (fname=) messagen fname (array) dc message
+           fname tag 5 eq not {
+             [(MSG) (<h1> Invalid file name. </h1>)]
+             httpd_sendfile
+             /httpd_sendfile.L1 /httpd_sendfile.L1 goto
+           } {  } ifelse
+           fname (array) dc /fname set
+           fname length 1 lt {
+             /fname (index.html) (array) dc def
+           } {  } ifelse
+
+           fname [47] eq {
+              /fname (index.html) (array) dc def
+           }{ } ifelse
+
+           fname 0 get 47 eq {  %% /
+             /fname fname rest def
+           } {  } ifelse
+
+           fname { (string) dc } map cat /fname  set
+       } ifelse
+
+       /fname2 fname def
+       [httpd.root fname2] cat /fname set
+       [(fname=) fname] cat message
+       fname httpd.check_name {
+         [(MSG) (Warning:  invalid file name.)] httpd_sendfile
+         /httpd_sendfile.L1 /httpd_sendfile.L1 goto
+       } {  } ifelse  
+       [(stat) fname] extension 0 get tag 0 eq {
+         [(MSG) (Warning (sendfile): the file )  fname2 ( is not found.) ]
+          httpd_sendfile
+         /httpd_sendfile.L1 /httpd_sendfile.L1 goto
+       }{  }ifelse
+       [(stat) fname] extension 1 get 0 get toString /fsize set
+       (HTTP/1.1 200 OK)  sendln
+       (Server: httpd_sm1) sendln
+       %% (ETag: "2197-bf6c-3b2d6541") sendln ???
+       (Accept-Ranges: bytes) sendln
+       [(Content-Length: ) fsize] cat  sendln
+       (Connection: close) sendln
+       [(Content-Type: ) fname httpd_type] cat sendln
+       [(flush)] extension 
+       0 sendln
+       fname sendBinaryFile
+       0 sendln
+       [(flush)] extension
+       0 sendln
+       [(flush)] extension
+       /httpd_sendfile.L1 goto
+     }{ 
+       [(MSG) (Warning: unknown argument type for httpd_sendfile)]
+       httpd_sendfile
+     } ifelse
+     /httpd_sendfile.L1 
+   ] pop
+   popVariables
+} def
+
+/httpd_type {
+  /arg1 set
+  [/in-httpd_type /fname /ftype /i /ans] pushVariables
+  [
+    /fname arg1 def
+    fname getFileType /ftype set
+
+    /ans (text/plain) def  % .txt, .jar, 
+    ftype (gif) eq {
+      /ans (image/gif) def
+    }{ } ifelse
+    ftype (jpeg) eq ftype (jpg) eq or {
+      /ans (image/jpeg) def
+    }{ } ifelse
+    ftype (png) eq {
+      /ans (image/png) def
+    }{ } ifelse
+    ftype (png) eq {
+      /ans (image/png) def
+    }{ } ifelse
+    ftype (html) eq ftype (htm) eq or {
+      /ans (text/html) def
+    } {  } ifelse
+    ftype (wav) eq {
+      /ans (audio/x-wav) def
+    } { } ifelse
+    ftype (class) eq {
+      /ans (application/octet-stream) def
+    } { } ifelse
+    /arg1 ans def
+  ] pop
+  popVariables
+  arg1  
+} def
+
+/httpd.check_name {
+ /arg1 set
+ [/in-httpd.check_name /fname /invalid] pushVariables
+ [
+   /fname arg1 def
+   /invalid 0 def
+   [(regionMatches) fname [(..) (/.)]] extension 0 get -1 eq 
+   {
+   } { 
+     (The file name contains .. or /. ) message
+     /invalid 1 def /httpd.check_name.L1 /httpd.check_name.L1  goto 
+   } ifelse
+   fname length 0 eq {
+     (Warning: empty file name.)
+     /invalid 1 def /httpd.check_name.L1 /httpd.check_name.L1  goto 
+   }{ } ifelse
+   fname (array) dc 0 get 47 eq {
+   }{
+     (Warning: The first letter is not /) message
+     /invalid 1 def /httpd.check_name.L1 /httpd.check_name.L1  goto 
+   } ifelse
+   /httpd.check_name.L1 
+   /arg1 invalid def
+ ] pop
+ popVariables
+ arg1
+} def
+
+/httpd.startBrowserUnix {
+  /arg1 set
+  [/portnum /browser /cmd /fd /msg /htmlfn] pushVariables
+  [
+     arg1 /portnum set
+     portnum toString /portnum set
+     [(getenv) (OX_BROWSER)]  extension /browser set
+     {
+      browser tag 0 eq {
+        [(sleep 3 ; netscape http://localhost:) portnum ( & ) ] cat
+        /cmd set cmd message
+        cmd system
+        exit
+       }{ } ifelse
+       browser (mac) eq, browser (MAC) eq, or {
+         (.sm1.httpd.startBrowserUnix.html) /htmlfn set
+         htmlfn (w) file /fd set
+         fd tag 0 eq { (httpd.startBrowserUnix fails to open a file.) error }
+         { } ifelse
+         [(<html><body>) nl 
+          (<a href="http://localhost:) portnum (">)
+          (Click here to connect to the ox server)
+          (</a>) nl
+          (</body></html>) nl
+         ] cat /msg set
+         fd msg writestring  fd closefile
+         [(sleep 3 ; open ) htmlfn ( &) ] cat
+         /cmd set cmd message
+         cmd system
+         exit   
+       }{ } ifelse
+       [(sleep 3 ; ) browser ( http://localhost:) portnum ( & ) ] cat
+       /cmd set cmd message
+       cmd system
+       exit
+     } loop
+  ] pop
+  popVariables
 } def
\ No newline at end of file