home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / internet / freenet / httpsrvr_0 / SERVER
Encoding:
Text File  |  1995-07-03  |  12.9 KB  |  442 lines
  1. REM >httpServer
  2. END=1024*128: REM 96K WimpSlot
  3.  
  4. REM Change this to be your authorisation keyword
  5. REM If you want a secure server, leave it as empty string
  6. root_pw$=""
  7.  
  8. REM Change this line to the root of your web pages
  9. lib$="ADFS::HardDisc5.$.Internet.WWWPages"
  10. end%=FALSE:socket%=-1:connect%=-1:cc%=0:maxknx%=4
  11.  
  12. lastmax%=TIME
  13. bufsiz%=1024
  14. port%=80
  15. nl$=CHR$10
  16. task$="HTTP Server ("+STR$port%+")"
  17. server$="Server: RISCOS/3.5 httpserver/0.8beta"
  18. sig$="RISC OS httpd 0.8 (Acorn RiscPC600 25MB) (<a href=""http://louis.ecs.soton.ac.uk/~snb94r/httpd.html"">S.N.Brodie</a>)"
  19. DIM taskid%8,q%&100,select_read%32,select_write%32,select_excep%32,timeout%8
  20. DIM iobuf%64,remotehost%16,hostsize%4,valid_sel%32,connect_sel%32
  21. DIM data_sel%32
  22. DIM knx%(maxknx%),port%(maxknx%),io%(maxknx%),ptr%(maxknx%),first%(maxknx%),url$(maxknx%)
  23. DIM file%(maxknx%),ext%(maxknx%),len%(maxknx%),file$(maxknx%),mime$(maxknx%),redir%(maxknx%)
  24. DIM rocont$(maxknx%)
  25. url$() = STRING$(254," "):url$() = "": REM Reserve memory NOW
  26. file$() = STRING$(254," "):file$() = "": REM Ditto
  27. mime$() = "application/octet-stream": mime$() = "": REM Ditto
  28. rocont$() = "X-RiscOS-Filetype: xxx "
  29. redir%() = 0
  30. ptr%()=0
  31. knx%()=-1
  32. file%()=-1
  33. ON ERROR:PROC_errstop:END
  34. PROC_init
  35. $taskid%="TASK"
  36. SYS "Wimp_Initialise", 310, !taskid%, task$, -1 TO ,task_id%
  37. del%=0
  38. WHILE NOT end%
  39.   SYS "Wimp_PollIdle",,q%,FN_timenow+del% TO reason%
  40.   CASE reason% OF
  41.     WHEN 1: SYS "Wimp_RedrawWindow",,q% TO more%
  42.             WHILE more%:SYS "Wimp_GetRectange",,q% TO more%:ENDWHILE
  43.     WHEN 2: SYS "Wimp_OpenWindow",,q%
  44.     WHEN 3: SYS "Wimp_CloseWindow",,q%
  45.     WHEN 17,18: PROC_message
  46.     OTHERWISE: PROC_select
  47.   ENDCASE
  48. ENDWHILE
  49. PROC_exit
  50. END
  51.  
  52. DEF FN_lower(A$):LOCALB$,B%,C%:B$="":FORB%=1 TO LENA$:C%=ASCMID$(A$,B%)
  53. IFC%>=65 AND C%<=90 C%+=32
  54. B$+=CHR$C%:NEXT:=B$
  55.  
  56. DEF FN_timenow:LOCALA%:SYS "OS_ReadMonotonicTime" TO A%:=A%
  57.  
  58. DEF FN_task_same
  59. y$="":y%=q%+28:WHILE (?y%) >=32:y$+=CHR$(?y%):y%+=1:ENDWHILE
  60. =(y$=task$)
  61.  
  62. DEF FN_zero(ptr%):LOCAL A$:A$=""
  63. WHILELENA$<255 AND ?ptr%:A$+=CHR$(?ptr%):ptr%+=1:ENDWHILE
  64. =A$
  65.  
  66. DEF PROC_message
  67. IF q%!16 = 0 THEN end%=TRUE
  68. IF q%!16 = &400C2 AND FN_task_same AND q%!4 <> task_id% THEN end%=TRUE
  69. ENDPROC
  70.  
  71. DEF PROC_fd_zero(base%)
  72. LOCAL T%:FORT%=0 TO 28 STEP 4:base%!T%=0:NEXT
  73. ENDPROC
  74.  
  75. DEF PROC_fd_copy(base%,dest%)
  76. LOCAL T%:FORT%=0 TO 28 STEP 4:dest%!T%=base%!T%:NEXT
  77. ENDPROC
  78.  
  79. DEF PROC_fd_set(base%, fd%)
  80. IF fd%<0 OR fd%>255 THEN ENDPROC
  81. WHILE fd%>=8 :base%+=1:fd%-=8:ENDWHILE
  82. ?base%=(?base% OR (1<<fd%))
  83. ENDPROC
  84.  
  85. DEF PROC_fd_clr(base%, fd%)
  86. IF fd%<0 OR fd%>255 THEN ENDPROC
  87. WHILE fd%>=8 :base%+=1:fd%-=8:ENDWHILE
  88. ?base%=(?base% AND NOT (1<<fd%))
  89. ENDPROC
  90.  
  91. DEF FN_fd_isset(base%, fd%)
  92. IF fd%<0 OR fd%>255 THEN =FALSE
  93. WHILE fd%>=8:base%+=1:fd%-=8:ENDWHILE
  94. IF ((?base%) AND (1<<fd%)) = (1<<fd%) THEN = TRUE:
  95. =FALSE
  96.  
  97. DEF PROC_accept
  98. LOCAL X%,a$
  99. IF cc%=maxknx% THEN
  100.   IF TIME>lastmax% PROC_debug(3,"max connections")
  101.   lastmax%=TIME+500
  102.   ENDPROC
  103. ENDIF
  104. !hostsize%=16
  105. SYS "Socket_Accept", socket%, remotehost%, hostsize% TO connect%
  106. IF connect%=-1 THEN PROC_debug(0,"Failed "):ENDPROC
  107. PROC_fd_set(data_sel%, connect%)
  108. cc%+=1
  109. a$=STR$(remotehost%?4)+"."+STR$(remotehost%?5)+"."
  110. a$+=STR$(remotehost%?6)+"."+STR$(remotehost%?7)
  111. use_rev_dns%=TRUE
  112. IF use_rev_dns% THEN
  113.   SYS "XInternet_GetHostByAddr",,remotehost%+4,4,2 TO ,shp%
  114.   IF shp%>0 THEN a$=FN_zero(!shp%)
  115. ENDIF
  116. PROC_debug(0,a$+" wants http")
  117. FOR X%=1 TO maxknx%:IF knx%(X%)=-1 THEN
  118.   knx%(X%)=connect%:port%(X%)=port%:ptr%(X%)=0:first%(X%)=0:redir%(X%)=0:X%=maxknx%
  119. ENDIF
  120. NEXT
  121. connect%=-1
  122. ENDPROC
  123.  
  124. DEF PROC_conn_kill(x%)
  125. break%=TRUE
  126. IF knx%(x%) > -1 THEN
  127.   PROC_debug(3,"Closing socket "+STR$knx%(x%))
  128.   SYS "XSocket_Shutdown", knx%(x%), 2
  129.   SYS "XSocket_Close", knx%(x%)
  130.   PROC_fd_clr(data_sel%, knx%(x%))
  131.   knx%(x%)=-1
  132.   cc%-=1
  133. ENDIF
  134. IF file%(x%)>0 CLOSE #file%(x%):file%(x%)=-1
  135. url$(x%)=""
  136. ENDPROC
  137.  
  138. DEF PROC_sock_write(sock%, str$)
  139. IF LENstr$>60 THEN
  140.   PROC_sock_write(sock%, LEFT$(str$,60))
  141.   PROC_sock_write(sock%, MID$(str$,61))
  142. ELSE
  143.   $iobuf% = str$
  144.   SYS "XSocket_Write", sock%, iobuf%, LENstr$
  145. ENDIF
  146. ENDPROC
  147.  
  148. DEF PROC_resp_screen(x%,code%,id$,reason$)
  149. LOCAL s%:s%=knx%(x%)
  150. LOCAL ERROR
  151. ON ERROR LOCAL ON ERROR LOCAL OFF:ENDPROC
  152. PROC_sock_write(s%, "HTTP/1.0 "+STR$code%+" "+id$+nl$+"MIME-version: 1.0"+nl$)
  153. PROC_sock_write(s%, server$+nl$)
  154. PROC_sock_write(s%, "Content-type: text/html"+nl$+nl$)
  155. PROC_sock_write(s%, "<head><title>"+STR$code%+" "+id$+"</title></head>"+nl$)
  156. PROC_sock_write(s%, "<body><h1>"+STR$code%+" "+id$+"</h1>"+nl$+reason$)
  157. IF code%=302 ENDPROC
  158. PROC_sock_write(s%, "<p>"+nl$+"<hr>"+nl$+sig$+"</body>"+nl$)
  159. ENDPROC
  160.  
  161. DEF PROC_redirect(x%)
  162. PROC_debug(0,"302 Relocate for "+url$(x%))
  163. PROC_resp_screen(x%, 302, "Not here", "The requested document is no longer at this URL")
  164. PROC_sock_write(s%, "<p>It has moved to <a href=""")
  165. PROC_sock_write(s%, file$(x%))
  166. PROC_sock_write(s%, """>another location</a><p><hr>"+nl$)
  167. PROC_sock_write(s%, sig$+nl$)
  168. PROC_conn_kill(x%)
  169. ENDPROC
  170.  
  171. DEF PROC_not_found(x%)
  172. PROC_debug(0,"404 Not found for "+url$(x%))
  173. PROC_resp_screen(x%,404,"Not found","The request URL was not found on this server")
  174. PROC_conn_kill(x%)
  175. ENDPROC
  176.  
  177. DEF PROC_bad_request(x%)
  178. PROC_debug(0,"400 Bad access method")
  179. PROC_resp_screen(x%, 400, "Bad request", "Your client sent a query that the server could not understand")
  180. PROC_conn_kill(x%)
  181. ENDPROC
  182.  
  183.  
  184. DEF PROC_retrieve_url(x%, full%)
  185. PROC_debug(0,"200 OK for "+url$(x%))
  186. LOCAL ERROR
  187. ON ERROR LOCAL ON ERROR LOCAL OFF:ENDPROC
  188. file%(x%)=OPENIN file$(x%)
  189. IF file%(x%)=0 THEN PROC_not_found(x%):PROC_conn_kill(x%):ENDPROC
  190. SYS "OS_Args",2,file%(x%) TO ,,ext%(x%)
  191. ptr%(x%)=0
  192. len%(x%)=0
  193. IF mime$(x%)="" THEN
  194.   PROC_debug(0,"Executing CGI script "+url$(x%))
  195.   CLOSE #file%(x%)
  196.   file%(x%)=-1
  197.   tmp$="http/1.0":IF NOT full% tmp$="http/0.9"
  198.   SYS "Wimp_StartTask", file$(x%)+" "+tmp$+" -socket "+STR$knx%(x%)
  199.   break%=TRUE
  200.   cc%-=1
  201.   knx%(x%)=-1
  202.   url$(x%)=""
  203. ELSE
  204.   IF NOT full% THEN ENDPROC
  205.   PROC_sock_write(knx%(x%), "HTTP/1.0 200 OK" + nl$)
  206.   PROC_sock_write(knx%(x%), server$+nl$)
  207.   PROC_sock_write(knx%(x%), "MIME-version: 1.0"+nl$)
  208.   PROC_sock_write(knx%(x%), "Content-Type: " +mime$(x%)+ nl$)
  209.   PROC_sock_write(knx%(x%), "Content-Length: "+STR$ext%(x%)+nl$)
  210.   PROC_sock_write(knx%(x%), rocont$(x%)+nl$)
  211.   PROC_sock_write(knx%(x%), nl$)
  212. ENDIF
  213. ENDPROC
  214.  
  215. DEF PROC_do_o(x%)
  216. IF len%(x%)=0 THEN
  217.   SYS "OS_GBPB", 4, file%(x%), io%(x%), bufsiz% TO ,,,unread%
  218.   len%(x%) = bufsiz%-unread%: IF unread%=bufsiz% THEN PROC_conn_kill(x%):ENDPROC
  219. ENDIF
  220. SYS "XSocket_Write", knx%(x%), io%(x%), len%(x%)
  221. len%(x%)=0
  222. ENDPROC
  223.  
  224. DEF PROC_io_filbuf(fdset%)
  225. LOCAL x%
  226. FOR x%=1 TO maxknx%
  227.   IF FN_fd_isset(fdset%,knx%(x%)) PROC_do_o(x%)
  228. NEXT
  229. ENDPROC
  230.  
  231. DEF FN_xlate(p$)
  232. LOCAL p%,q$:q$="":FOR p%=1 TO LENp$
  233. CASE MID$(p$,p%,1) OF
  234.   WHEN "/": q$+="."
  235.   WHEN ".": q$+="/"
  236.   WHEN ":","$","%","&", "^", "*", """", "@", "#", "<", ">": =""
  237.   OTHERWISE: q$+=MID$(p$,p%,1)
  238. ENDCASE
  239. NEXT
  240. =q$
  241.  
  242. DEF PROC_lookup(x%,p$)
  243. LOCAL was_cgi%
  244. IF LEFT$(p$,1) <> "/" p$="/"+p$
  245. was_cgi% = (FN_lower((LEFT$(p$,9))) = "/cgi-bin/")
  246. p$=FN_xlate(p$)
  247. IF p$="" THEN PROC_not_found(x%):PROC_conn_kill(x%):ENDPROC
  248. IF RIGHT$(p$,1) = ".": p$+="index/html"
  249. file$(x%)=lib$+LEFT$(p$,255-LENlib$)
  250. SYS "OS_File", 23, file$(x%) TO obj%,,,,,,type%
  251. PROC_debug(2,file$(x%)+" "+STR$obj%+" "+STR$~type%)
  252. IF obj%=3 obj%=1
  253. IF obj%=2 OR obj%=3 file$(x%)+=".index/html":SYS "OS_File", 23, file$(x%) TO obj%,,,,,,type%
  254. IF obj%<>1 THEN PROC_not_found(x%):PROC_conn_kill(x%):ENDPROC
  255. IF was_cgi% THEN mime$(x%)="":ENDPROC
  256. rocont$(x%)="X-RiscOS-Filetype: "+STR$~type%
  257. CASE type% OF
  258.   WHEN &FAF,&345: mime$(x%)="text/html"
  259.   WHEN &FFF: mime$(x%)="text/plain"
  260.   WHEN &695: mime$(x%)="image/gif"
  261.   WHEN &C85: mime$(x%)="image/jpeg"
  262.   WHEN &AE7: mime$(x%)="video/armovie"
  263.   WHEN &BF8: mime$(x%)="video/mpeg"
  264.   WHEN &FF8,&FFB: mime$(x%)="application/octet-stream"
  265.   WHEN &DDC: mime$(x%)="application/x-sparkive"
  266.   WHEN &3FB, &1000, &2000: mime$(x%)="application/x-arcfs"
  267.   OTHERWISE: PROC_not_found(x%): PROC_conn_kill(x%)
  268. ENDCASE
  269. ENDPROC
  270.  
  271. DEF PROC_authorise(x%,p$)
  272. IF LEFT$(p$,LENroot_pw$) <> root_pw$ THEN PROC_debug(0,"ROOT authentication failed"):ENDPROC
  273. mime$(x%)="application/octet-stream"
  274. file$(x%)=MID$(p$,2+LENroot_pw$)
  275. PROC_debug(0,"ROOT authorisation for "+file$(x%))
  276. ENDPROC
  277.  
  278. DEF PROC_io(y%)
  279. LOCAL x%,p%,flag%
  280. LOCAL ERROR: ON ERROR LOCAL OFF: PROC_conn_kill(x%):break%=TRUE:PROC_debug(0,REPORT$+" "+STR$ERL):ENDPROC
  281. FOR x%=1 TO maxknx%
  282.   IF FN_fd_isset(y%,knx%(x%)) THEN
  283.     SYS "XSocket_Read",knx%(x%),iobuf%,1 TO bytes_read%;flag%
  284.     IF (flag%AND1)=1 THEN PROC_conn_kill(x%):PROC_debug(0,REPORT$):break%=TRUE:ENDPROC
  285.     IF (bytes_read%=0 AND first%(x%) < 2) THEN
  286.       bytes_read%=1
  287.       ?iobuf%=10
  288.     ENDIF
  289.     CASE bytes_read% OF
  290.     WHEN -1:
  291.       PROC_debug(0,"exceptional condition on socket (read failed) closing")
  292.       PROC_conn_kill(x%)
  293.     WHEN 0:
  294.       PROC_debug(0,"no more input on socket")
  295.       PROC_conn_kill(x%)
  296.     OTHERWISE:
  297.       IF (first%(x%)>1):NEXT:ENDPROC
  298.       c%=?iobuf%
  299.       ptr%(x%)?io%(x%)=c%
  300.       IF (c% = 10) THEN
  301.         IF first%(x%)=1 THEN
  302.           p%=0
  303.           p$="":WHILE LENp$<254 AND p%<ptr%(x%):p$+=CHR$(p%?io%(x%)):p%+=1:ENDWHILE
  304.           IF RIGHT$(p$,1) = CHR$13: p$=LEFT$(p$)
  305.           IF LEFT$(p$,10)="Authorise:" THEN PROC_authorise(x%,MID$(p$,12))
  306.           PROC_debug(3,p$)
  307.         ENDIF
  308.         IF first%(x%)=0 THEN
  309.           first%(x%)=1
  310.           p$="":FOR p%=0 TO 3:p$+=CHR$(io%(x%)?p%):NEXT
  311.           IF p$ <> "GET ":PROC_bad_request(x%):PROC_debug(0,"HDR:"+p$):ENDPROC
  312.           p$="":WHILE LENp$<254 AND p%?io%(x%) <> 10 AND p%?io%(x%)<>13
  313.             p$+=CHR$(p%?io%(x%)):p%+=1
  314.           ENDWHILE
  315.           IF (p%?io%(x%) <> 10 AND p%?io%(x%) <> 13) THEN
  316.                 PROC_not_found(x%):PROC_conn_kill(x%):NEXT:ENDPROC
  317.           ENDIF
  318.           IF RIGHT$(p$,8)="HTTP/1.0" THEN p$=LEFT$(p$,LENp$-9):full%=TRUE:ELSE:full%=FALSE
  319.           url$(x%)=p$
  320.           PROC_debug(3,"requested "+p$)
  321.           PROC_lookup(x%, p$)
  322.           IF (knx%(x%)>-1) AND NOT full% THEN
  323.             first%(x%)=2:PROC_retrieve_url(x%, FALSE)
  324.           ENDIF
  325.         ELSE
  326.           IF (ptr%(x%)=0 OR (ptr%(x%)=1 AND ?io%(x%)=13)) AND first%(x%) = 1 THEN
  327.                 PROC_debug(3,"Finished reading headers - sending")
  328.                 first%(x%)=2
  329.                 IF redir%(x%)=0 THEN PROC_retrieve_url(x%,TRUE) ELSE PROC_redirect(x%)
  330.           ENDIF
  331.           REM Ignore other headers for now
  332.         ENDIF
  333.         ptr%(x%) = 0
  334.       ELSE
  335.         ptr%(x%)+=1
  336.       ENDIF
  337.     ENDCASE
  338.   ENDIF
  339. NEXT
  340. ENDPROC
  341.  
  342. DEF PROC_validate_all_sockets
  343. LOCAL K%,x%
  344. FOR x%=1 TO maxknx%
  345.   IF knx%(x%) > -1 THEN
  346.     timeout%!4=16
  347.     SYS "XSocket_Getsockname",knx%(x%), valid_sel%, timeout%+4 TO ;K%
  348.     IF (K%AND1)=1 THEN
  349.       PROC_conn_kill(x%)
  350.       PROC_debug(0,"validate: killing socket")
  351.     ENDIF
  352.   ENDIF
  353. NEXT
  354. ENDPROC
  355.  
  356. DEF PROC_select
  357. LOCAL word%,byte%,bit%,y%,choice%,lo%
  358. LOCAL ERROR
  359. ON ERROR LOCAL ON ERROR LOCAL OFF:PROC_debug(0,REPORT$+" "+STR$ERL):ENDPROC
  360. del%=20
  361. break%=FALSE
  362. IF socket%=-1 THEN end%=TRUE:ENDPROC
  363. !timeout%=0:timeout%!4=0
  364. PROC_fd_copy(connect_sel%,valid_sel%)
  365. SYS "XSocket_Select",256,valid_sel%,0,0,timeout% TO choice%;y%
  366. IF (y%AND1)=1  THEN end%=TRUE:ENDPROC:REM Serious error on control socket
  367. IF choice%>0 THEN PROC_accept
  368.  
  369. PROC_fd_copy(data_sel%, select_excep%)
  370. !timeout%=0:timeout%!4=0
  371. SYS "XSocket_Select",256,0,0,select_excep%,timeout% TO choice%;y%
  372. IF (y%AND1)=1 THEN PROC_validate_all_sockets:ENDPROC
  373. IF choice%>0 THEN PROC_io(select_excep%)
  374.  
  375. FOR lo%=1 TO 100
  376.   !timeout%=0:timeout%!4=0
  377.   PROC_fd_copy(data_sel%, select_read%)
  378.   SYS "XSocket_Select",256,select_read%,0,0,timeout% TO choice%;y%
  379.   IF (y%AND1)=1 THEN
  380.     PROC_validate_all_sockets:ENDPROC
  381.   ENDIF
  382.   IF choice%>0 THEN
  383.     PROC_io(select_read%):del%=0
  384.   ELSE
  385.     lo%=100
  386.   ENDIF
  387. NEXT
  388. :
  389. !timeout%=0:timeout%!4=0
  390. PROC_fd_copy(data_sel%, select_write%)
  391. FOR y%=1 TO maxknx%
  392.   IF NOT (knx%(y%)>-1 AND first%(y%)>1) PROC_fd_clr(select_write%, knx%(y%))
  393. NEXT
  394. SYS "XSocket_Select",256,0,select_write%,0,timeout% TO choice%;y%
  395. IF (y%AND1)=0 AND choice%>0 THEN PROC_io_filbuf(select_write%):del%=0
  396. ENDPROC
  397.  
  398. DEF PROC_htons(address%,value%)
  399. address%?0 = (value% DIV 256)
  400. address%?1 = (value% MOD 256)
  401. ENDPROC
  402.  
  403. DEF PROC_init
  404. LOCAL ERROR:ON ERROR LOCAL OFF:PROC_debug(0,STR$ERR+" "+REPORT$):ENDPROC
  405. AF_INET% = 2: SOCK_STREAM% = 1
  406. DIM address% 16
  407. SYS "Socket_Creat", AF_INET%, SOCK_STREAM%, 0 TO socket%
  408. IF socket%<0 OR socket%>31 ERROR EXT 0,"Unable to Create Socket"
  409. !address%=2
  410. PROC_htons(address%+2,port%)
  411. address%!4 = 0 :address%!8 = 0: address%!12 = 0
  412. SYS "Socket_Bind", socket%, address%, 16
  413. SYS "Socket_Listen", socket%, 5
  414. PROC_fd_zero(connect_sel%)
  415. PROC_fd_set(connect_sel%,socket%)
  416. PROC_fd_zero(data_sel%)
  417. PROC_debug(0,"starting")
  418. FOR X%=1 TO maxknx%
  419.   DIM mem% bufsiz%
  420.   io%(X%)=mem%
  421. NEXT
  422. ENDPROC
  423.  
  424. DEF PROC_exit
  425. IF socket%  <> -1: SYS "XSocket_Shutdown",socket%,2:SYS "XSocket_Close", socket%
  426. IF connect% <> -1:SYS "XSocket_Shutdown",connect%,2:SYS "XSocket_Close", connect%
  427. FOR x%=1 TO maxknx%
  428.   IF knx%(x%)>=0 PROC_conn_kill(x%)
  429. NEXT
  430. ENDPROC
  431.  
  432. DEF PROC_errstop
  433. ON ERROR OFF:PROC_debug(0,REPORT$+" ("+STR$ERL+")")
  434. PROC_exit
  435. END
  436. ENDPROC
  437.  
  438. DEF PROC_debug(lev%,x$)
  439. LOCAL ERROR:ON ERROR LOCAL OFF:ENDPROC
  440. SYS "XInternet_Syslog","httpd",x$,lev%
  441. ENDPROC
  442.