REM >httpServer
END=1024*128: REM 96K WimpSlot

REM Change this to be your authorisation keyword
REM If you want a secure server, leave it as empty string
root_pw$=""

REM Change this line to the root of your web pages
lib$="ADFS::HardDisc5.$.Internet.WWWPages"
end%=FALSE:socket%=-1:connect%=-1:cc%=0:maxknx%=4

lastmax%=TIME
bufsiz%=1024
port%=80
nl$=CHR$10
task$="HTTP Server ("+STR$port%+")"
server$="Server: RISCOS/3.5 httpserver/0.8beta"
sig$="RISC OS httpd 0.8 (Acorn RiscPC600 25MB) (<a href=""http://louis.ecs.soton.ac.uk/~snb94r/httpd.html"">S.N.Brodie</a>)"
DIM taskid%8,q%&100,select_read%32,select_write%32,select_excep%32,timeout%8
DIM iobuf%64,remotehost%16,hostsize%4,valid_sel%32,connect_sel%32
DIM data_sel%32
DIM knx%(maxknx%),port%(maxknx%),io%(maxknx%),ptr%(maxknx%),first%(maxknx%),url$(maxknx%)
DIM file%(maxknx%),ext%(maxknx%),len%(maxknx%),file$(maxknx%),mime$(maxknx%),redir%(maxknx%)
DIM rocont$(maxknx%)
url$() = STRING$(254," "):url$() = "": REM Reserve memory NOW
file$() = STRING$(254," "):file$() = "": REM Ditto
mime$() = "application/octet-stream": mime$() = "": REM Ditto
rocont$() = "X-RiscOS-Filetype: xxx "
redir%() = 0
ptr%()=0
knx%()=-1
file%()=-1
ON ERROR:PROC_errstop:END
PROC_init
$taskid%="TASK"
SYS "Wimp_Initialise", 310, !taskid%, task$, -1 TO ,task_id%
del%=0
WHILE NOT end%
  SYS "Wimp_PollIdle",,q%,FN_timenow+del% TO reason%
  CASE reason% OF
    WHEN 1: SYS "Wimp_RedrawWindow",,q% TO more%
            WHILE more%:SYS "Wimp_GetRectange",,q% TO more%:ENDWHILE
    WHEN 2: SYS "Wimp_OpenWindow",,q%
    WHEN 3: SYS "Wimp_CloseWindow",,q%
    WHEN 17,18: PROC_message
    OTHERWISE: PROC_select
  ENDCASE
ENDWHILE
PROC_exit
END

DEF FN_lower(A$):LOCALB$,B%,C%:B$="":FORB%=1 TO LENA$:C%=ASCMID$(A$,B%)
IFC%>=65 AND C%<=90 C%+=32
B$+=CHR$C%:NEXT:=B$

DEF FN_timenow:LOCALA%:SYS "OS_ReadMonotonicTime" TO A%:=A%

DEF FN_task_same
y$="":y%=q%+28:WHILE (?y%) >=32:y$+=CHR$(?y%):y%+=1:ENDWHILE
=(y$=task$)

DEF FN_zero(ptr%):LOCAL A$:A$=""
WHILELENA$<255 AND ?ptr%:A$+=CHR$(?ptr%):ptr%+=1:ENDWHILE
=A$

DEF PROC_message
IF q%!16 = 0 THEN end%=TRUE
IF q%!16 = &400C2 AND FN_task_same AND q%!4 <> task_id% THEN end%=TRUE
ENDPROC

DEF PROC_fd_zero(base%)
LOCAL T%:FORT%=0 TO 28 STEP 4:base%!T%=0:NEXT
ENDPROC

DEF PROC_fd_copy(base%,dest%)
LOCAL T%:FORT%=0 TO 28 STEP 4:dest%!T%=base%!T%:NEXT
ENDPROC

DEF PROC_fd_set(base%, fd%)
IF fd%<0 OR fd%>255 THEN ENDPROC
WHILE fd%>=8 :base%+=1:fd%-=8:ENDWHILE
?base%=(?base% OR (1<<fd%))
ENDPROC

DEF PROC_fd_clr(base%, fd%)
IF fd%<0 OR fd%>255 THEN ENDPROC
WHILE fd%>=8 :base%+=1:fd%-=8:ENDWHILE
?base%=(?base% AND NOT (1<<fd%))
ENDPROC

DEF FN_fd_isset(base%, fd%)
IF fd%<0 OR fd%>255 THEN =FALSE
WHILE fd%>=8:base%+=1:fd%-=8:ENDWHILE
IF ((?base%) AND (1<<fd%)) = (1<<fd%) THEN = TRUE:
=FALSE

DEF PROC_accept
LOCAL X%,a$
IF cc%=maxknx% THEN
  IF TIME>lastmax% PROC_debug(3,"max connections")
  lastmax%=TIME+500
  ENDPROC
ENDIF
!hostsize%=16
SYS "Socket_Accept", socket%, remotehost%, hostsize% TO connect%
IF connect%=-1 THEN PROC_debug(0,"Failed "):ENDPROC
PROC_fd_set(data_sel%, connect%)
cc%+=1
a$=STR$(remotehost%?4)+"."+STR$(remotehost%?5)+"."
a$+=STR$(remotehost%?6)+"."+STR$(remotehost%?7)
use_rev_dns%=TRUE
IF use_rev_dns% THEN
  SYS "XInternet_GetHostByAddr",,remotehost%+4,4,2 TO ,shp%
  IF shp%>0 THEN a$=FN_zero(!shp%)
ENDIF
PROC_debug(0,a$+" wants http")
FOR X%=1 TO maxknx%:IF knx%(X%)=-1 THEN
  knx%(X%)=connect%:port%(X%)=port%:ptr%(X%)=0:first%(X%)=0:redir%(X%)=0:X%=maxknx%
ENDIF
NEXT
connect%=-1
ENDPROC

DEF PROC_conn_kill(x%)
break%=TRUE
IF knx%(x%) > -1 THEN
  PROC_debug(3,"Closing socket "+STR$knx%(x%))
  SYS "XSocket_Shutdown", knx%(x%), 2
  SYS "XSocket_Close", knx%(x%)
  PROC_fd_clr(data_sel%, knx%(x%))
  knx%(x%)=-1
  cc%-=1
ENDIF
IF file%(x%)>0 CLOSE #file%(x%):file%(x%)=-1
url$(x%)=""
ENDPROC

DEF PROC_sock_write(sock%, str$)
IF LENstr$>60 THEN
  PROC_sock_write(sock%, LEFT$(str$,60))
  PROC_sock_write(sock%, MID$(str$,61))
ELSE
  $iobuf% = str$
  SYS "XSocket_Write", sock%, iobuf%, LENstr$
ENDIF
ENDPROC

DEF PROC_resp_screen(x%,code%,id$,reason$)
LOCAL s%:s%=knx%(x%)
LOCAL ERROR
ON ERROR LOCAL ON ERROR LOCAL OFF:ENDPROC
PROC_sock_write(s%, "HTTP/1.0 "+STR$code%+" "+id$+nl$+"MIME-version: 1.0"+nl$)
PROC_sock_write(s%, server$+nl$)
PROC_sock_write(s%, "Content-type: text/html"+nl$+nl$)
PROC_sock_write(s%, "<head><title>"+STR$code%+" "+id$+"</title></head>"+nl$)
PROC_sock_write(s%, "<body><h1>"+STR$code%+" "+id$+"</h1>"+nl$+reason$)
IF code%=302 ENDPROC
PROC_sock_write(s%, "<p>"+nl$+"<hr>"+nl$+sig$+"</body>"+nl$)
ENDPROC

DEF PROC_redirect(x%)
PROC_debug(0,"302 Relocate for "+url$(x%))
PROC_resp_screen(x%, 302, "Not here", "The requested document is no longer at this URL")
PROC_sock_write(s%, "<p>It has moved to <a href=""")
PROC_sock_write(s%, file$(x%))
PROC_sock_write(s%, """>another location</a><p><hr>"+nl$)
PROC_sock_write(s%, sig$+nl$)
PROC_conn_kill(x%)
ENDPROC

DEF PROC_not_found(x%)
PROC_debug(0,"404 Not found for "+url$(x%))
PROC_resp_screen(x%,404,"Not found","The request URL was not found on this server")
PROC_conn_kill(x%)
ENDPROC

DEF PROC_bad_request(x%)
PROC_debug(0,"400 Bad access method")
PROC_resp_screen(x%, 400, "Bad request", "Your client sent a query that the server could not understand")
PROC_conn_kill(x%)
ENDPROC


DEF PROC_retrieve_url(x%, full%)
PROC_debug(0,"200 OK for "+url$(x%))
LOCAL ERROR
ON ERROR LOCAL ON ERROR LOCAL OFF:ENDPROC
file%(x%)=OPENIN file$(x%)
IF file%(x%)=0 THEN PROC_not_found(x%):PROC_conn_kill(x%):ENDPROC
SYS "OS_Args",2,file%(x%) TO ,,ext%(x%)
ptr%(x%)=0
len%(x%)=0
IF mime$(x%)="" THEN
  PROC_debug(0,"Executing CGI script "+url$(x%))
  CLOSE #file%(x%)
  file%(x%)=-1
  tmp$="http/1.0":IF NOT full% tmp$="http/0.9"
  SYS "Wimp_StartTask", file$(x%)+" "+tmp$+" -socket "+STR$knx%(x%)
  break%=TRUE
  cc%-=1
  knx%(x%)=-1
  url$(x%)=""
ELSE
  IF NOT full% THEN ENDPROC
  PROC_sock_write(knx%(x%), "HTTP/1.0 200 OK" + nl$)
  PROC_sock_write(knx%(x%), server$+nl$)
  PROC_sock_write(knx%(x%), "MIME-version: 1.0"+nl$)
  PROC_sock_write(knx%(x%), "Content-Type: " +mime$(x%)+ nl$)
  PROC_sock_write(knx%(x%), "Content-Length: "+STR$ext%(x%)+nl$)
  PROC_sock_write(knx%(x%), rocont$(x%)+nl$)
  PROC_sock_write(knx%(x%), nl$)
ENDIF
ENDPROC

DEF PROC_do_o(x%)
IF len%(x%)=0 THEN
  SYS "OS_GBPB", 4, file%(x%), io%(x%), bufsiz% TO ,,,unread%
  len%(x%) = bufsiz%-unread%: IF unread%=bufsiz% THEN PROC_conn_kill(x%):ENDPROC
ENDIF
SYS "XSocket_Write", knx%(x%), io%(x%), len%(x%)
len%(x%)=0
ENDPROC

DEF PROC_io_filbuf(fdset%)
LOCAL x%
FOR x%=1 TO maxknx%
  IF FN_fd_isset(fdset%,knx%(x%)) PROC_do_o(x%)
NEXT
ENDPROC

DEF FN_xlate(p$)
LOCAL p%,q$:q$="":FOR p%=1 TO LENp$
CASE MID$(p$,p%,1) OF
  WHEN "/": q$+="."
  WHEN ".": q$+="/"
  WHEN ":","$","%","&", "^", "*", """", "@", "#", "<", ">": =""
  OTHERWISE: q$+=MID$(p$,p%,1)
ENDCASE
NEXT
=q$

DEF PROC_lookup(x%,p$)
LOCAL was_cgi%
IF LEFT$(p$,1) <> "/" p$="/"+p$
was_cgi% = (FN_lower((LEFT$(p$,9))) = "/cgi-bin/")
p$=FN_xlate(p$)
IF p$="" THEN PROC_not_found(x%):PROC_conn_kill(x%):ENDPROC
IF RIGHT$(p$,1) = ".": p$+="index/html"
file$(x%)=lib$+LEFT$(p$,255-LENlib$)
SYS "OS_File", 23, file$(x%) TO obj%,,,,,,type%
PROC_debug(2,file$(x%)+" "+STR$obj%+" "+STR$~type%)
IF obj%=3 obj%=1
IF obj%=2 OR obj%=3 file$(x%)+=".index/html":SYS "OS_File", 23, file$(x%) TO obj%,,,,,,type%
IF obj%<>1 THEN PROC_not_found(x%):PROC_conn_kill(x%):ENDPROC
IF was_cgi% THEN mime$(x%)="":ENDPROC
rocont$(x%)="X-RiscOS-Filetype: "+STR$~type%
CASE type% OF
  WHEN &FAF,&345: mime$(x%)="text/html"
  WHEN &FFF: mime$(x%)="text/plain"
  WHEN &695: mime$(x%)="image/gif"
  WHEN &C85: mime$(x%)="image/jpeg"
  WHEN &AE7: mime$(x%)="video/armovie"
  WHEN &BF8: mime$(x%)="video/mpeg"
  WHEN &FF8,&FFB: mime$(x%)="application/octet-stream"
  WHEN &DDC: mime$(x%)="application/x-sparkive"
  WHEN &3FB, &1000, &2000: mime$(x%)="application/x-arcfs"
  OTHERWISE: PROC_not_found(x%): PROC_conn_kill(x%)
ENDCASE
ENDPROC

DEF PROC_authorise(x%,p$)
IF LEFT$(p$,LENroot_pw$) <> root_pw$ THEN PROC_debug(0,"ROOT authentication failed"):ENDPROC
mime$(x%)="application/octet-stream"
file$(x%)=MID$(p$,2+LENroot_pw$)
PROC_debug(0,"ROOT authorisation for "+file$(x%))
ENDPROC

DEF PROC_io(y%)
LOCAL x%,p%,flag%
LOCAL ERROR: ON ERROR LOCAL OFF: PROC_conn_kill(x%):break%=TRUE:PROC_debug(0,REPORT$+" "+STR$ERL):ENDPROC
FOR x%=1 TO maxknx%
  IF FN_fd_isset(y%,knx%(x%)) THEN
    SYS "XSocket_Read",knx%(x%),iobuf%,1 TO bytes_read%;flag%
    IF (flag%AND1)=1 THEN PROC_conn_kill(x%):PROC_debug(0,REPORT$):break%=TRUE:ENDPROC
    IF (bytes_read%=0 AND first%(x%) < 2) THEN
      bytes_read%=1
      ?iobuf%=10
    ENDIF
    CASE bytes_read% OF
    WHEN -1:
      PROC_debug(0,"exceptional condition on socket (read failed) closing")
      PROC_conn_kill(x%)
    WHEN 0:
      PROC_debug(0,"no more input on socket")
      PROC_conn_kill(x%)
    OTHERWISE:
      IF (first%(x%)>1):NEXT:ENDPROC
      c%=?iobuf%
      ptr%(x%)?io%(x%)=c%
      IF (c% = 10) THEN
        IF first%(x%)=1 THEN
          p%=0
          p$="":WHILE LENp$<254 AND p%<ptr%(x%):p$+=CHR$(p%?io%(x%)):p%+=1:ENDWHILE
          IF RIGHT$(p$,1) = CHR$13: p$=LEFT$(p$)
          IF LEFT$(p$,10)="Authorise:" THEN PROC_authorise(x%,MID$(p$,12))
          PROC_debug(3,p$)
        ENDIF
        IF first%(x%)=0 THEN
          first%(x%)=1
          p$="":FOR p%=0 TO 3:p$+=CHR$(io%(x%)?p%):NEXT
          IF p$ <> "GET ":PROC_bad_request(x%):PROC_debug(0,"HDR:"+p$):ENDPROC
          p$="":WHILE LENp$<254 AND p%?io%(x%) <> 10 AND p%?io%(x%)<>13
            p$+=CHR$(p%?io%(x%)):p%+=1
          ENDWHILE
          IF (p%?io%(x%) <> 10 AND p%?io%(x%) <> 13) THEN
                PROC_not_found(x%):PROC_conn_kill(x%):NEXT:ENDPROC
          ENDIF
          IF RIGHT$(p$,8)="HTTP/1.0" THEN p$=LEFT$(p$,LENp$-9):full%=TRUE:ELSE:full%=FALSE
          url$(x%)=p$
          PROC_debug(3,"requested "+p$)
          PROC_lookup(x%, p$)
          IF (knx%(x%)>-1) AND NOT full% THEN
            first%(x%)=2:PROC_retrieve_url(x%, FALSE)
          ENDIF
        ELSE
          IF (ptr%(x%)=0 OR (ptr%(x%)=1 AND ?io%(x%)=13)) AND first%(x%) = 1 THEN
                PROC_debug(3,"Finished reading headers - sending")
                first%(x%)=2
                IF redir%(x%)=0 THEN PROC_retrieve_url(x%,TRUE) ELSE PROC_redirect(x%)
          ENDIF
          REM Ignore other headers for now
        ENDIF
        ptr%(x%) = 0
      ELSE
        ptr%(x%)+=1
      ENDIF
    ENDCASE
  ENDIF
NEXT
ENDPROC

DEF PROC_validate_all_sockets
LOCAL K%,x%
FOR x%=1 TO maxknx%
  IF knx%(x%) > -1 THEN
    timeout%!4=16
    SYS "XSocket_Getsockname",knx%(x%), valid_sel%, timeout%+4 TO ;K%
    IF (K%AND1)=1 THEN
      PROC_conn_kill(x%)
      PROC_debug(0,"validate: killing socket")
    ENDIF
  ENDIF
NEXT
ENDPROC

DEF PROC_select
LOCAL word%,byte%,bit%,y%,choice%,lo%
LOCAL ERROR
ON ERROR LOCAL ON ERROR LOCAL OFF:PROC_debug(0,REPORT$+" "+STR$ERL):ENDPROC
del%=20
break%=FALSE
IF socket%=-1 THEN end%=TRUE:ENDPROC
!timeout%=0:timeout%!4=0
PROC_fd_copy(connect_sel%,valid_sel%)
SYS "XSocket_Select",256,valid_sel%,0,0,timeout% TO choice%;y%
IF (y%AND1)=1  THEN end%=TRUE:ENDPROC:REM Serious error on control socket
IF choice%>0 THEN PROC_accept

PROC_fd_copy(data_sel%, select_excep%)
!timeout%=0:timeout%!4=0
SYS "XSocket_Select",256,0,0,select_excep%,timeout% TO choice%;y%
IF (y%AND1)=1 THEN PROC_validate_all_sockets:ENDPROC
IF choice%>0 THEN PROC_io(select_excep%)

FOR lo%=1 TO 100
  !timeout%=0:timeout%!4=0
  PROC_fd_copy(data_sel%, select_read%)
  SYS "XSocket_Select",256,select_read%,0,0,timeout% TO choice%;y%
  IF (y%AND1)=1 THEN
    PROC_validate_all_sockets:ENDPROC
  ENDIF
  IF choice%>0 THEN
    PROC_io(select_read%):del%=0
  ELSE
    lo%=100
  ENDIF
NEXT
:
!timeout%=0:timeout%!4=0
PROC_fd_copy(data_sel%, select_write%)
FOR y%=1 TO maxknx%
  IF NOT (knx%(y%)>-1 AND first%(y%)>1) PROC_fd_clr(select_write%, knx%(y%))
NEXT
SYS "XSocket_Select",256,0,select_write%,0,timeout% TO choice%;y%
IF (y%AND1)=0 AND choice%>0 THEN PROC_io_filbuf(select_write%):del%=0
ENDPROC

DEF PROC_htons(address%,value%)
address%?0 = (value% DIV 256)
address%?1 = (value% MOD 256)
ENDPROC

DEF PROC_init
LOCAL ERROR:ON ERROR LOCAL OFF:PROC_debug(0,STR$ERR+" "+REPORT$):ENDPROC
AF_INET% = 2: SOCK_STREAM% = 1
DIM address% 16
SYS "Socket_Creat", AF_INET%, SOCK_STREAM%, 0 TO socket%
IF socket%<0 OR socket%>31 ERROR EXT 0,"Unable to Create Socket"
!address%=2
PROC_htons(address%+2,port%)
address%!4 = 0 :address%!8 = 0: address%!12 = 0
SYS "Socket_Bind", socket%, address%, 16
SYS "Socket_Listen", socket%, 5
PROC_fd_zero(connect_sel%)
PROC_fd_set(connect_sel%,socket%)
PROC_fd_zero(data_sel%)
PROC_debug(0,"starting")
FOR X%=1 TO maxknx%
  DIM mem% bufsiz%
  io%(X%)=mem%
NEXT
ENDPROC

DEF PROC_exit
IF socket%  <> -1: SYS "XSocket_Shutdown",socket%,2:SYS "XSocket_Close", socket%
IF connect% <> -1:SYS "XSocket_Shutdown",connect%,2:SYS "XSocket_Close", connect%
FOR x%=1 TO maxknx%
  IF knx%(x%)>=0 PROC_conn_kill(x%)
NEXT
ENDPROC

DEF PROC_errstop
ON ERROR OFF:PROC_debug(0,REPORT$+" ("+STR$ERL+")")
PROC_exit
END
ENDPROC

DEF PROC_debug(lev%,x$)
LOCAL ERROR:ON ERROR LOCAL OFF:ENDPROC
SYS "XInternet_Syslog","httpd",x$,lev%
ENDPROC