REBOL [
    Title: "REBOL Web Server"
    Date: 11-Apr-2001
    Version: 0.0.0.9
    File: %webserv.r
    Author: "Cal Dixon"
    Purpose: {A Simple HTTP-Server that can run REBOL CGI scripts }
    Comment: {
      (c) 2000, 2001 Cal Dixon
      Requires Rebol/Core 2.5 or Rebol/View 1.0 or later
         By default the server will look for pages to serve in a folder called "www" in the
      current directory.  It will listen on port 80 and generate a log-file called
      "webserv.log".  Files with unrecognized types will be sent as "text/html".
      Settings can be changed by creating a configuration file called "webserv-cfg.r".
      EXAMPLE configuration file ---- cut here ---
         wwwpath: %./WWW/          ; change this to where the files are...
         port: 8080                ; change this to whatever port the server should listen to
         logfile: %webserv.log     ; the name of the logfile or set to none
         default-type: "application/octet-stream" ; Content-Type for unrecognized extensions
      --- cut here --- END of example file
      To make the server recognize additional content types, create a file called
      "content-types.r" and list pairs of extensions (without the dot) and content types.
      EXAMPLE content-type file ---- cut here ---
      "lha" "application/octet-stream"
      "png" "image/png"
      "mp3" "audio/mp3"
      "rar" "application/x-rar-compressed"
      "rtf" "application/rtf"
      "zip" "application/x-zip-compressed"
      --- cut here --- END of example file

      Files with an extension of ".r" or ".cgi" will be treated as Rebol CGI scripts.  Output
      from CGI scripts is not buffered; everything is sent directly to the browser.
      Files with an extension of ".rhtml" are pre-proccesed by the server.  Anything enclosed
      in a pair of ":[" and "]:" will be executed as rebol code and the value of the expression
      will be inserted into the document at that location.

      To start the server:
         Place the %webserv.r script in a folder, start up rebol, change to the directory
         the script is in, then type "do %webserv.r".

      Future versions:
         If I do another update other than bug-fixes, the features I'm considering adding are
         a web-based control panel and manual, possibly multi-threaded operation for CGI
         scripts under /View, and if I get Rebol/View/Pro I'll probably add support for
         non-rebol CGI scripts.
      }
    History: [
    0.0.0.3 {This version redirects all i/o to the web browser so 'read-io on 
              system/ports/input can be used to get POSTed data, etc.} 
    0.0.0.4 {Now has better error checking and passes content-length as a string like it 
               should} 
    0.0.0.5 "Can now send multiple files at once" 
    0.0.0.6 {Now patches 'print and 'prin to work correctly and passes all http headers to           
              CGIs also translates access to a folder to %index.html in that folder.  Also  
              handles the HTTP HEAD method in addition to GET and sends the "Last-Modified"  
              header} 
    0.0.0.7 {Added logging in Extended Common Log Format - but for CGI scripts the number of
              bytes sent is recorded as 1, due to current limitations of this program  } 
    0.0.0.8 "Updated to work with Rebol/Core 2.5" 
    0.0.0.9 {Added configuration file support, documentation, and .html preprocessing}
]
    Email: rebol@programmer.net
    Category: [web cgi tcp]
]

wwwpath: %./www/          ; change this to where the files are...
port: 80                  ; change this to whatever port the server should listen to
logfile: %webserv.log     ; the name of the logfile or set to none
default-type: "text/html" ; Content-Type for unrecognized extensions

secure none
content-type-list: append [
      "txt"   "text/plain"
      "gif"   "image/gif" 
      "jpg"   "image/jpeg" 
      "png"   "image/png" 
      "mov"   "video/quicktime" 
      "tif"   "image/tiff" 
      "tiff"  "image/tiff" 
      "wav"   "audio/wav" 
      "xml"   "text/xml" 
      "xsl"   "text/xml" 
      "mid"   "audio/midi" 
      "rhtml" "rhtml"
      "r"     none
      "cgi"   none
      ] either exists? %content-types.r [ load %content-types.r ] [ [] ]
if exists? %webserv-cfg.r [ do %webserv-cfg.r ] 
system/options/quiet: true
e: {<HTML><HEAD><TITLE>404 Not Found</TITLE></HEAD><BODY>Page not found.</BODY></HTML>}
cgi-obj: make system/options/cgi [ context: func [] [ return 'context ] ]
listen: open/lines/direct join tcp://: port
inport: system/ports/input
outport: system/ports/output
queue: []

; these replacements for 'print and 'prin should work better for CGI scripts
prin: func [ out /local data ] [
   data: replace/all (reform out) newline "^M^J"
   write-io system/ports/output data length? data
   return
   ]

print: func [ out /local data ] [
   data: replace/all (reform out) newline "^M^J"
   data: append data "^M^J"
   write-io system/ports/output data length? data
   return
   ]

quit: halt: func [] [throw]

www-send: func [ conn data ] [ write-io conn data length? data ]
either logfile [
   write-log: func [ entry ] [ write/append logfile join to-string entry newline ]
   ][
   write-log: func [ ignorethisvalue ] []
   ]

get-http-headers: func [ conn /local line buffer a b c ] [
   buffer: copy []
   while [ ((line: first conn) <> "") and not none? line ] [
      a: copy/part line b: find line ":"
      c: trim next b
      insert buffer reduce [ a c ]
      ]
   return buffer
   ]

handle-cgi: func [ conn request query headers /local cd ] [
   system/options/cgi: make cgi-obj compose [
      server-software: "REBOL Web Server"
      server-name: (read dns://)
      gateway-interface: "CGI/1.1"
      server-protocol: "HTTP/1.0"
      server-port: "80"
      query-string: (query)
      request-method: (pick request 1)
      script-name: (first parse (pick request 2) "?")
      Content-Type: (select headers "Content-Type")
      Content-Length: (select headers "Content-Length")
      other-headers: (headers)
      ]
   cd: what-dir
   system/ports/output: conn
   system/ports/input: conn
   www-send conn "HTTP/1.0 200 OK^/"
   if error? try [ catch [ do file-path ] ] []
   system/ports/input: inport
   system/ports/output: outport
   change-dir cd
   close conn
   ]

content-type?: func [ filename [string! file!] ] [
   first any [
      select/skip content-type-list next find/last to-string filename "." 2 [default-type]
      ]
   ]

process-queue: func [ /local connection data file conn newqueue ] [
   newqueue: copy []
   foreach connection queue [
      set [ conn file ] connection
      data: copy/part file 2048
      file: skip file 2048
      write-io conn data length? data
      either tail? file [
         close conn
         ] [
         insert/only newqueue reduce [ conn file ]
         ]
      ]
   queue: newqueue
   ]

send-header: func [ conn result content-type data-length ] [
   www-send conn rejoin [ "HTTP/1.0 " result newline "Content-Type: " content-type newline
      "Content-Length: " data-length newline "Date: " to-idate now newline 
      "Last-Modified: " to-idate modified? file-path "^/^/" ]
   ]

translate-request-to-resource: func [ file /local file-path ] [
   if (last file) = #"/" [ append file "index.html" ]
   file-path: clean-path join wwwpath to-file next file
   if none? find file-path clean-path wwwpath [
      file-path: clean-path join wwwpath "index.html"
      ]
   if dir? file-path [ append file-path "/index.html" ]
   return file-path
   ]

http-log: func [ host request status bytes /extended headers /local when agent referer] [
   when: rejoin [ replace/all copy/part mold now 11 "-" "/" replace skip mold now 11 "/" ":" ]
   replace when "-" " -"
   either (agent: select headers "User-Agent") [
      agent: join {"} [ agent {"} ]
      ][
      agent: "-"
      ]
   either (referer: select headers "Referer") [
     referer: join {"} [ referer {"} ]
     ][
     referer: "-"
     ]
   reform [
      host
      "- -" 
      rejoin [ "[" when "]" ] 
      mold form request
      status
      bytes
      either extended [
         reform [ referer agent ]
         ][ "" ]
      ]
   ]

rhtml: func [ text /local p out pos s p1 p2] [
   p: [ (out: copy "" pos: 1) s:
      any [
         thru ":[" p1: copy code to "]:"
         p2: (
            repend out [(copy/part at s pos ((index? p1) - 2 - pos) )(do code)]
            pos: 2 + index? p2
            )
         ]
      to end (append out at s pos)
      ]
   return either error? try [ parse text p ] [ text ] [ out ]
   ]

handle-new-connections: func [ /local data conn http-headers ] [
   if none? wait reduce [ listen 0 ] [ return ]
   if error? try [ request: parse first (conn: first listen) none ] [ close conn return ]
   if (length? queue) > 3000 [
      insert conn "HTTP/1.0 503 Server Overloaded^/"
      close conn return
      ] ; refuse connections if server is overloaded
   request-method: pick request 1
   set [ file urlquery ] parse (pick request 2) "?"
   file-path: translate-request-to-resource file
   http-headers: get-http-headers conn
   either exists? file-path [
      either none? content: content-type? file-path [
         write-log http-log/extended conn/host request 200 1 http-headers
         handle-cgi conn request urlquery http-headers
         return
         ] [
         write-log http-log/extended conn/host request 200 size? file-path http-headers
         set [ responce data ] reduce [ "200 OK" (data: read/binary file-path) ]
         ]
      ] [
      write-log http-log/extended conn/host request 404 0 http-headers
      set [ responce content data file-path ] reduce [ "404 Not Found" "text/html" e %. ]
      ]
   if content = "rhtml" [
      content: "text/html"
      data: rhtml data
      ]
   send-header conn responce content length? data
   if request-method = "HEAD" [ close conn return ]
   insert/only queue reduce [ conn data ]
   ]


forever [
   if ( zero? ( length? queue ) ) [ wait listen ]
   handle-new-connections
   process-queue
   ]