
(********************************************************************)
(*                                                                  *)
(*  comanche.sd7  Simple webserver for static and cgi pages.        *)
(*  Copyright (C) 2009 - 2011  Thomas Mertes                        *)
(*                                                                  *)
(*  This program is free software; you can redistribute it and/or   *)
(*  modify it under the terms of the GNU General Public License as  *)
(*  published by the Free Software Foundation; either version 2 of  *)
(*  the License, or (at your option) any later version.             *)
(*                                                                  *)
(*  This program is distributed in the hope that it will be useful, *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of  *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the   *)
(*  GNU General Public License for more details.                    *)
(*                                                                  *)
(*  You should have received a copy of the GNU General Public       *)
(*  License along with this program; if not, write to the           *)
(*  Free Software Foundation, Inc., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(********************************************************************)


$ include "seed7_05.s7i";
  include "osfiles.s7i";
  include "duration.s7i";
  include "socket.s7i";
  include "listener.s7i";
  include "shell.s7i";
  include "getf.s7i";

var string: htdocs is "../htdocs";
var string: cgi_bin is "../prg";
var integer: port is 1080;


const proc: sendHttpResponse (inout file: sock, in string: response,
    in var string: contentType, in array string: header) is func
  local
    var string: line is "";
    var string: status is "";
  begin
    for line range header do
      if startsWith(line, "Status") then
        status := trim(line[succ(pos(line, ":")) ..]);
      elsif startsWith(line, "Content-Type") then
        contentType := trim(line[succ(pos(line, ":")) ..]);
      end if;
    end for;
    if status = "" then
      writeln(sock, "HTTP/1.1 200 OK");
    else
      writeln(sock, "HTTP/1.1 " <& status);
    end if;
    writeln(sock, "Server: Comanche");
    writeln(sock, "Transfer-Encoding: identity");
    # writeln("Content-Length: " <& length(response));
    writeln(sock, "Content-Length: " <& length(response));
    if contentType <> "" then
      writeln(sock, "Content-Type: " <& contentType);
    elsif startsWith(response, "\137\PNG") then
      writeln(sock, "Content-Type: image/png");
    elsif pos(response, "<html") = 0 then
      writeln(sock, "Content-Type: text/html");
    else
      writeln(sock, "Content-Type: text/plain");
    end if;
    for line range header do
      if not startsWith(line, "Content-Type") then
        writeln(sock, line);
      end if;
    end for;
    writeln(sock);
    write(sock, response);
  end func;


const proc: sendClientError (inout file: sock, in string: message,
    in string: explanation) is func
  local
    var string: htmlMessage is "";
  begin
    htmlMessage := "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
                   \<html><head>\n\
                   \<title>" <& message <& "</title>\n\
                   \</head><body>\n\
                   \<h1>Not Found</h1>\n\
                   \<p>" <& explanation <& "</p>\n\
                   \<hr>\n\
                   \<address>Comanche</address>\n\
                   \</body></html>\n";
    writeln(sock, "HTTP/1.1 " <& message);
    writeln(sock, "Server: Comanche");
    writeln(sock, "Transfer-Encoding: identity");
    writeln(sock, "Content-Length: " <& length(htmlMessage));
    writeln(sock, "Content-Type: text/html");
    writeln(sock);
    write(sock, htmlMessage);
  end func;


const func string: callCgi (in string: filePath, in string: queryParams,
    in string: postParams, in string: cookies, inout array string: header) is func
  result
    var string: response is "";
  local
    var string: cgiPath is "";
    var string: tempName is "";
    var file: cgiInput is STD_NULL;
    var file: cgiOutput is STD_NULL;
    var string: line is "";
  begin
    # writeln("CGI " <& filePath <& " " <& queryParams);
    # writeln(postParams);
    cgiPath := toStdPath(cgi_bin & filePath[9 ..]);
    setenv("QUERY_STRING", queryParams);
    setenv("HTTP_COOKIE", cookies);
    tempName := "cgiInput_" & str(rand(0, 99999));
    cgiInput := open(tempName, "w");
    writeln(cgiInput, postParams);
    # writeln(cgiInput, "*");
    # writeln(cgiInput, "*");
    close(cgiInput);
    if endsWith(cgiPath, ".sd7") then
      cgiOutput := popen("./s7 -q " <& cgiPath & " < " & tempName, "r");
    else
      cgiOutput := popen(cgiPath & " < " & tempName, "r");
    end if;
    if cgiOutput <> STD_NULL then
      line := getln(cgiOutput);
      while line <> "" do
        # writeln(line);
        header &:= [] (line);
        line := getln(cgiOutput);
      end while;
      # writeln;
      response := gets(cgiOutput, 999999999);
      # writeln(length(response));
      # writeln(literal(response));
      close(cgiOutput);
      removeFile(tempName);
    end if;
    if response = "" then
      header &:= "Status: 404 Not Found";
      header &:= "Content-Type: text/html";
      response := "<html><head>\n\
                  \<title>CGI Error</title>\n\
                  \</head><body>\n\
                  \<h1>CGI Error</h1>\n\
                  \<p>The requested CGI script " <& filePath <&
                  " could not be executed or did not produce any output.</p>\n\
                  \<p>Query params: " <& queryParams <& "</p>\n\
                  \<p>Post params: " <& postParams <& "</p>\n\
                  \<hr>\n\
                  \<address>Comanche</address>\n\
                  \</body></html>\n";
    end if;
  end func;


const proc: processHttpRequest (inout file: sock) is func
  local
    var string: line is "";
    var string: requestCommand is "";
    var string: requestPath is "";
    var string: filePath is "";
    var string: hostName is "";
    var integer: questionMarkPos is 0;
    var string: queryParams is "";
    var string: postParams is "";
    var string: cookies is "";
    var array string: cgiHeader is 0 times "";
    var string: buffer is "";
    var string: contentType is "";
    var string: contentLengthStri is "";
    var integer: contentLength is 0;
  begin
    line := getln(sock);
    # writeln(literal(line));
    while line <> "" do
      # writeln(line);
      if startsWith(line, "GET") then
        requestCommand := "GET";
        requestPath := trim(line[4 ..]);
        requestPath := requestPath[.. pred(pos(requestPath, ' '))];
      elsif startsWith(line, "POST") then
        requestCommand := "POST";
        requestPath := trim(line[5 ..]);
        requestPath := requestPath[.. pred(pos(requestPath, ' '))];
      elsif startsWith(line, "Host") then
        hostName := trim(line[succ(pos(line, ":")) ..]);
      elsif startsWith(line, "Content-Length") then
        contentLengthStri := trim(line[succ(pos(line, ":")) ..]);
        block
          contentLength := integer parse contentLengthStri;
        exception
          catch RANGE_ERROR:
            contentLength := -1;
        end block;
      elsif startsWith(line, "Cookie") then
        cookies := trim(line[succ(pos(line, ":")) ..]);
      end if;
      line := getln(sock);
    end while;
    if requestCommand = "GET" then
      # writeln("GET" <& requestPath);
      questionMarkPos := pos(requestPath, '?');
      if questionMarkPos <> 0 then
        queryParams := requestPath[succ(questionMarkPos) ..];
        requestPath := requestPath[.. pred(questionMarkPos)];
      end if;
      filePath := replace(requestPath, "\\", "/");
      if startsWith(filePath, "/cgi-bin/") then
        buffer := callCgi(filePath, queryParams, "", cookies, cgiHeader);
        if buffer <> "" then
          sendHttpResponse(sock, buffer, "", cgiHeader);
        end if;
      else
        filePath := toStdPath(htdocs & "/" & filePath);
        # writeln(literal(filePath));
        if fileType(filePath) = FILE_ABSENT then
          if fileType(filePath & ".html") <> FILE_ABSENT then
            filePath &:= ".html";
          elsif fileType(filePath & ".htm") <> FILE_ABSENT then
            filePath &:= ".htm";
          end if;
        elsif fileType(filePath) = FILE_DIR then
          if fileType(filePath & "/index.html") <> FILE_ABSENT then
            filePath &:= "/index.html";
          elsif fileType(filePath & "/index.htm") <> FILE_ABSENT then
            filePath &:= "/index.htm";
          end if;
        end if;
        if fileType(filePath) = FILE_REGULAR then
          buffer := getf(filePath);
        else
          buffer := "";
        end if;
        if buffer <> "" then
          if endsWith(filePath, ".htm") or endsWith(filePath, ".html") then
            contentType := "text/html";
          end if;
          sendHttpResponse(sock, buffer, contentType, 0 times "");
        end if;
      end if;
      if buffer = "" then
        sendClientError(sock, "404 Not Found",
            "The requested URL " <& requestPath <&
            " was not found on this server.");
      end if;
    elsif requestCommand = "POST" then
      # writeln("POST" <& requestPath);
      questionMarkPos := pos(requestPath, '?');
      if questionMarkPos <> 0 then
        queryParams := requestPath[succ(questionMarkPos) ..];
        requestPath := requestPath[.. pred(questionMarkPos)];
      end if;
      # writeln(queryParams);
      if contentLengthStri <> "" then
        while contentLength <> 0 do
          buffer := gets(sock, contentLength);
          contentLength -:= length(buffer);
          postParams &:= buffer;
        end while;
      elsif inputReady(sock, 1 . SECONDS) then
        buffer := gets(sock, 10000000);
        while buffer <> "" do
          postParams &:= buffer;
          if inputReady(sock, 1 . SECONDS) then
            buffer := gets(sock, 10000000);
          else
            buffer := "";
          end if;
        end while;
      end if;
      buffer := "";
      # writeln(postParams);
      filePath := replace(requestPath, "\\", "/");
      if startsWith(filePath, "/cgi-bin/") then
        buffer := callCgi(filePath, queryParams, postParams, cookies, cgiHeader);
      end if;
      if buffer <> "" then
        sendHttpResponse(sock, buffer, "", cgiHeader);
      else
        sendClientError(sock, "404 Not Found",
            "The requested URL " <& requestPath <&
            " was not found on this server.");
      end if;
    end if;
  end func;


const proc: main is func
  local
    var boolean: okay is TRUE;
    var listener: inetListener is listener.value;
    var file: sock is socket.value;
  begin
    writeln("Comanche Version 1.1 - Simple webserver for static and cgi pages");
    writeln("Copyright (C) 2009 - 2011 Thomas Mertes");
    writeln("This is free software; see the source for copying conditions.  There is NO");
    writeln("warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.");
    writeln("Comanche is written in the Seed7 programming language");
    writeln("Homepage: http://seed7.sourceforge.net");
    if length(argv(PROGRAM)) >= 1 then
      htdocs := argv(PROGRAM)[1];
      if length(argv(PROGRAM)) >= 2 then
        cgi_bin := argv(PROGRAM)[2];
        if length(argv(PROGRAM)) >= 3 and isDigitString(argv(PROGRAM)[3]) then
          block
            port := integer parse (argv(PROGRAM)[3]);
          exception
            catch RANGE_ERROR: writeln(" ***** Port number too big. Port " <&
                port <& " used instead.");
          end block;
        end if;
      end if;
    end if;
    if htdocs in {"-h", "-?"} then
      writeln;
      writeln("usage: comanche [html-directory [cgi-directory [port]]]");
      writeln;
      writeln("The html-directory specifies the root directory for HTML files.");
      writeln("The default html-directory is \"../htdocs\".");
      writeln("The cgi-directory specifies the root directory for CGI scripts.");
      writeln("The default cgi-directory is \"../prg\".");
      writeln("The default port is 1080.");
    else
      if fileType(htdocs) <> FILE_DIR then
        writeln(" *** Directory " <& literal(htdocs) <& " not found.");
        writeln("     You need to specify a directory which contains");
        writeln("     at least \"index.htm\" and possibly other HTML files.");
        okay := FALSE;
      end if;
      if fileType(cgi_bin) <> FILE_DIR then
        writeln(" *** Directory " <& literal(cgi_bin) <& " not found.");
        writeln("     You need to specify a directory which contains");
        writeln("     executable CGI scripts.");
        okay := FALSE;
      end if;
      if not okay then
        writeln("Use the option -? (or -h) to get more information.");
      else
        writeln("HTML directory: " <& htdocs);
        writeln("CGI directory: " <& cgi_bin);
        writeln("Port: " <& port);
        inetListener := openInetListener(port);
        listen(inetListener, 10);
        writeln("To test comanche make sure that " <&
                literal(htdocs & "/index.htm") <& " exists and");
        writeln("open http://localhost:" <& port <& "/ in your browser. \
                \To stop comanche press CTRL-C.");
        while TRUE do
          sock := accept(inetListener);
          block
            processHttpRequest(sock);
          exception
            catch FILE_ERROR:
              noop;
          end block;
          close(sock);
        end while;
      end if;
    end if;
  end func;
