MODULE SimpleWeb;

IMPORT CIText, Fmt, IP, Rd, TextWr, Wr, RdCopy, RdUtils,
       Thread, URLCache, Web, Text, Pathname, IO;

CONST
  MIMETypeAsText = ARRAY Web.MIMEType OF
                     TEXT{"application", "audio", "image", "message",
                          "multipart", "text", "video", "X-????"};

VAR
  extensionTypes := ARRAY [0..8] OF ExtensionType{
      ExtensionType{"gif",Web.MIMEType.Image,"gif"},
      ExtensionType{"jpeg",Web.MIMEType.Image,"jpeg"},
      ExtensionType{"pnm",Web.MIMEType.Image,"pnm"},
      ExtensionType{"ppm",Web.MIMEType.Image,"ppm"},
      ExtensionType{"pbm",Web.MIMEType.Image,"pbm"},
      ExtensionType{"pgm",Web.MIMEType.Image,"pgm"},
      ExtensionType{"htm",Web.MIMEType.Text,"html"},
      ExtensionType{"html",Web.MIMEType.Text,"html"},
      ExtensionType{"txt",Web.MIMEType.Text,"plain"}};

PROCEDURE Setup(READONLY a: ARRAY OF ExtensionType) =
  BEGIN
    extensionTypes := a;
  END Setup;

PROCEDURE Fetch (         url    : TEXT;
                 READONLY accepts: ARRAY OF TEXT := DefaultAccepts;
                          reload : BOOLEAN       := FALSE;
                          server : Web.T         := NIL             ):
  Web.Page RAISES {Thread.Alerted} =
  BEGIN
    RETURN DoFetch(url, accepts, reload, server, 1);
  END Fetch;

PROCEDURE DoFetch (         url    : TEXT;
                   READONLY accepts: ARRAY OF TEXT := DefaultAccepts;
                            reload : BOOLEAN;
                            server : Web.T;
                            linkCt : INTEGER                          ):
  Web.Page RAISES {Thread.Alerted} =
  <* FATAL Wr.Failure *>
  VAR
    header  : Web.Header;
    contents: TEXT;
    rd      : Rd.T;
    wr                   := TextWr.New();

  PROCEDURE Error (msg: TEXT) =
    VAR errorHeader: Web.Header;
    BEGIN
      contents := "** error fetching url '" & url & "': " & msg;
      header := errorHeader;
      header.httpVersion := "";
      header.statusCode := 0;
      header.reason := "";
      header.contentType := Web.MIMEType.Text;
      header.contentSubType := "plain";
    END Error;

  BEGIN
    IF reload OR NOT URLCache.Get (url, header, contents) THEN
      TRY
        TRY
          IF Text.Length(url) >= 5 AND
             Text.Equal("http:",Text.Sub(url,0,6)) THEN
            rd := Web.Get(url, header, forceCache := reload, server := server);
          ELSIF Text.Length(url) >= 5 AND
             Text.Equal("file:",Text.Sub(url,0,5)) THEN
            rd := FileGet(Text.Sub(url,5), header, forceCache := reload,
                server := server);
          ELSIF Text.Length(url) >= 1 AND Text.GetChar(url,0) = '/' THEN
            rd := FileGet(url, header, forceCache := reload, server := server);
          ELSE
            rd := Web.Get(url, header, forceCache := reload, server := server);
          END;

          IF (header.statusCode = 301 OR header.statusCode = 302)
               AND header.location # NIL THEN
            IF linkCt > 5 THEN
              Error("url has moved and moved and ...")
            ELSE
              RETURN DoFetch(header.location, accepts, reload, server,
                             linkCt + 1)
            END
          ELSIF header.statusCode >= 300 THEN
            Error(header.reason)
          ELSIF NOT Acceptable(header, accepts) THEN
            Error("cannot handle content type '"
                    & MIMETypeAsText[header.contentType] & "/"
                    & header.contentSubType & "'")
          ELSE
            EVAL RdCopy.ToWriter(rd, wr);
            contents := TextWr.ToText(wr);
            URLCache.Put (url, header, contents)
          END;
        EXCEPT
        | Web.Error (msg) => Error(msg)
        | IP.Error => Error("IP error; probably cannot connect to host")
        | Rd.Failure (code) =>
            Error(Fmt.F("reader failure: %s\n", RdUtils.FailureText(code)))
        END;
      FINALLY
        Wr.Close(wr);
        IF rd # NIL THEN
          TRY
            Rd.Close(rd)
          EXCEPT
            Rd.Failure (code) =>
              Error(Fmt.F("reader failure closing connection: %s\n",
                          RdUtils.FailureText(code)))
          END
        END
      END
    END;

    IF header.location = NIL THEN
      (* if the document moved and we have called DoFetch recursively to find it,
         the server doesn't always fill in the Location field. do this explicitly
         so clients will know the real URL *)
      header.location := url
    END;

    RETURN NEW(Web.Page, header := header, contents := contents);
  END DoFetch;

PROCEDURE FileGet(    url          : TEXT;
             VAR      header       : Web.Header;
  <*UNUSED*> READONLY requestFields: ARRAY OF TEXT := Web.DefaultRequestFields;
  <*UNUSED*>          forceCache   : BOOLEAN       := FALSE;
  <*UNUSED*>          debug        : BOOLEAN       := FALSE;
  <*UNUSED*>          server       : Web.T         := NIL): Rd.T
    RAISES {Web.Error} =
  VAR
    rd := IO.OpenRead(url);
    type: Web.MIMEType := Web.MIMEType.Text;
    subType := "plain";
  BEGIN
    IF rd = NIL THEN RAISE Web.Error("Cannot open file " & url); END;
    GetType(url,type,subType);
    header.httpVersion := "";
    header.statusCode := 0;
    header.reason := "";
    header.contentType := type;
    header.contentSubType := subType;
    RETURN rd;
  END FileGet;

PROCEDURE GetType(url: TEXT; VAR type: Web.MIMEType; VAR subType: TEXT) =
  VAR
    ext := Pathname.LastExt(url);
  BEGIN
    FOR i := 0 TO LAST(extensionTypes) DO
      IF Text.Equal(ext,extensionTypes[i].ext) THEN
        type := extensionTypes[i].type;
        subType := extensionTypes[i].subType;
      END;
    END;
  END GetType;

PROCEDURE Acceptable (READONLY header : Web.Header;
                      READONLY accepts: ARRAY OF TEXT): BOOLEAN =
  VAR
    t := MIMETypeAsText[header.contentType] & "/" & header.contentSubType;
  BEGIN
    FOR i := FIRST(accepts) TO LAST(accepts) DO
      IF CIText.Equal(t, accepts[i]) THEN RETURN TRUE END
    END;
    RETURN FALSE
  END Acceptable;

BEGIN
END SimpleWeb.