/*****************************************************************************/
/*
                                  LuaRTE.c

Lua run-time environment for WASD.

  https://www.lua.org/

  https://en.wikipedia.org/wiki/Lua_%28programming_language%29

  https://www.lua.org/manual/5.3/manual.html#4
  https://www.lua.org/source/5.3/
  https://www.lua.org/source/5.3/idx.html

Implements the proctocol described at

  https://github.com/keplerproject/wsapi/tree/master
  https://keplerproject.github.io/wsapi/manual.html





BUILD DETAILS
-------------
See BUILD_LUARTE.COM procedure.



COPYRIGHT
---------
Copyright (C) 2024 Mark G.Daniel
This program comes with ABSOLUTELY NO WARRANTY.
This is free software, and you are welcome to redistribute it under the
conditions of the GNU GENERAL PUBLIC LICENSE, version 3, or any later version.
http://www.gnu.org/licenses/gpl.txt



VERSION HISTORY (update SOFTWAREVN as well!)
---------------
21-APR-2024  MGD  v1.0.0, initial development
*/
/*****************************************************************************/

#define SOFTWAREVN "0.1.0"
#define SOFTWARENM "LUARTE"
#ifdef __ALPHA
#  define SOFTWAREID SOFTWARENM " AXP-" SOFTWAREVN
#endif
#ifdef __ia64
#  define SOFTWAREID SOFTWARENM " IA64-" SOFTWAREVN
#endif
#ifdef __x86_64
#  define SOFTWAREID SOFTWARENM " X86-" SOFTWAREVN
#endif

/* minimum VMS V7.0 */
#undef _VMS_V6_SOURCE
#undef __VMS_VER
#define __VMS_VER 70000000
#undef __CRTL_VER
#define __CRTL_VER 70000000

/* standard C header files */
#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <stdlib.h>
#include <string.h>
#include <stdlib.h>
#include <unixlib.h>
#include <unixio.h>
#include <fcntl.h>

/* Lua header files */
#include "lua$root:[include]lua.h"
#include "lua$root:[include]lauxlib.h"
#include "lua$root:[include]lualib.h"
#define THE_LUA_PATH "LUA$PATH"

/* VMS header files */
#include <descrip.h>
#include <fabdef.h>
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
#include <ssdef.h>
#include <starlet.h>

#define FI_LI "LUARTE", __LINE__

void at_exit ();
void CallOut (char*, int, char*, char*, ...);
char* CgiVar (char*);
void ProcessRequest ();
int ReadFileIntoMemory (char*, char**, int*);
int SimpleScript (char*);

int report (lua_State*);
int runlua (lua_State*, char*);

int WASD_Register (lua_State*);
int WASD_getenv (lua_State*);

#define WASD_ERROR_ALLOC  "memory allocation failed"
#define WASD_ERROR_ARGNUM "incorrect number of arguments"

int  Debug,
     ContentLength,
     ResponseHeader,
     UsageCount,
     UsageMax = 999999999,
     WatchScript;

char  *CgiEnvironmentPtr;

char  SoftwareID [] = SOFTWAREID " " THE_LUA_PATH;

static const struct luaL_Reg WASDlib[] = {
  { "getenv", WASD_getenv },
  { NULL, NULL }
};

lua_State *Lstate; 

/****************************************************************************/
/*
*/ 

int main
(
int argc,
char *argv[]
)
{
   char  *cptr;

   /*********/
   /* begin */
   /*********/

   if (!(stderr = freopen ("SYS$ERROR:", "w", stderr, "ctx=bin")))
      exit (vaxc$errno);
   stderr = freopen ("NL:", "w", stderr);
   if (!stderr) exit (vaxc$errno);
/**
**/

   if (!(stdout = freopen ("SYS$OUTPUT:", "w", stdout, "ctx=bin", "ctx=xplct")))
      exit (vaxc$errno);

   if (!(stdin = freopen ("HTTP$INPUT:", "r", stdin, "ctx=bin")))
      exit (vaxc$errno);

#ifdef __FEATURE_MODE_DEFVAL
   decc$feature_set ("DECC$EFS_CHARSET", 0, 1);
#else
   /* DECC$EFS_CHARSET needs to be set in a DCL wrapper procedure */
#endif

/****
   cptr = getenv ("WASD_LUA_PATH");
   if (!cptr) cptr = getenv ("LUA_PATH");
   if (cptr) setenv ("LUA_PATH", cptr, 1);

   cptr = getenv ("WASD_LUA_CPATH");
   if (!cptr) cptr = getenv ("LUA_CPATH");
   if (cptr) setenv ("LUA_CPATH", cptr, 1);
****/

   atexit (at_exit);

   while (CgiVar(NULL)) ProcessRequest ();

   exit (SS$_NORMAL);
}

/*****************************************************************************/
/*
Process a single CGI/CGIplus/RTE request.
All request processing occurs within this function.
*/

void ProcessRequest ()
       
{
   int  retval;
   unsigned long dwLength;
   char  *cptr, *sptr, *zptr,
         *ScriptFileName,
         *ScriptName;
   char  RunBuf [256];

   /*********/
   /* begin */
   /*********/

   if (Debug = (getenv("LUARTE$DBUG") != NULL))
      fputs ("Content-Type: text/plain\r\n\r\n", stdout);

   UsageCount++;

   ScriptName = CgiVar ("SCRIPT_NAME");
   ScriptFileName = CgiVar ("SCRIPT_FILENAME");

   Lstate = luaL_newstate();
   luaL_openlibs(Lstate);

   if (WatchScript)
   {
      const lua_Number  *vptr = lua_version (Lstate);
      char  luanumstr [32];
      sprintf (luanumstr, "%lf", *vptr);
      CallOut (FI_LI, NULL, "!UL <= !UL: !AZ !AZ !AZ !AZ",
               UsageCount, UsageMax, SoftwareID, luanumstr, ScriptFileName,
               (cptr = getenv(THE_LUA_PATH)) ? cptr : "(null)");
   }

   WASD_Register (Lstate);

   ResponseHeader = 0;

#if 0
//   if (!(retval = luaL_loadstring (Lstate, "require \"WASD\"")))
//      retval = lua_pcall (Lstate, 0, LUA_MULTRET, 0);

   if (!retval)
   {
      /* add the WASD-specific path component(s) */
      lua_getglobal(Lstate, "package");
      if (LUA_TTABLE != lua_type(Lstate, 1)) {
          printf("package is not a table\n");
          return;
      }
      lua_getfield(Lstate, 1, "path");
      if (LUA_TSTRING != lua_type(Lstate, 2)) {
          printf("package.path is not a string\n");
          return;
      }
      lua_pushliteral(Lstate, ";/wasd_root/src/lua/wsapi-1_3_4/src/?.lua");
      lua_concat(Lstate, 2);
      lua_setfield(Lstate, 1, "path");

      lua_getfield(Lstate, 1, "cpath");
      if (LUA_TSTRING != lua_type(Lstate, 2)) {
          printf("package.cpath is not a string\n");
          return;
      }
      lua_pushliteral(Lstate,
";/wasd_root/src/lua/luafilesystem-1_4_2/src/obj_axp/?");
      lua_concat(Lstate, 2);
      lua_setfield(Lstate, 1, "cpath");
   }

   if (!retval)
      if (!(retval = luaL_loadfile (Lstate, ScriptFileName)))
         retval = lua_pcall (Lstate, 0, LUA_MULTRET, 0);

   if (!retval)
   {
      zptr = (sptr = RunBuf) + sizeof(RunBuf)-1;
      for (cptr = "wsapi.common.run("; *cptr && sptr < zptr; *sptr++ = *cptr++);
      for (cptr = ScriptName; *cptr; cptr++);
      while (cptr > ScriptName && *cptr != '/') cptr--;
      if (*cptr == '/') cptr++;
      while (*cptr && *cptr != '.') *sptr++ = *cptr++;
      for (cptr = ".run, { input = io.stdin, output = io.stdout, \
error = io.stderr, env = WASD.getenv } )";
           *cptr && sptr < zptr;
           *sptr++ = *cptr++);
      *sptr = '\0';

      if (!(retval = luaL_loadstring (Lstate, RunBuf)))
         retval = lua_pcall (Lstate, 0, LUA_MULTRET, 0);
   }

#else

   retval = SimpleScript (ScriptFileName);

#endif

   if (retval) report (Lstate);

   lua_close (Lstate);

   Debug = 0;
}

/*****************************************************************************/
/*
*/

void at_exit ()
       
{
   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "at_exit()\n");

   if (WatchScript) CallOut (FI_LI, NULL, "!AZ", "LUA INTERPRETER EXITING");
}

/*****************************************************************************/
/*
*/

int SimpleScript (char *fname)
       
{
   int  length, retval, status;
   char  *text;

   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "SimpleScript\n");

   status = ReadFileIntoMemory (fname, &text, &length);
   if (!(status & 1))
   {
      fprintf (stdout, "Content-Type: text/plain\n\n%s %%X%08.08X\n",
               fname, status);
      return (1);
   }

   if (!(retval = luaL_loadstring (Lstate, text)))
      retval = lua_pcall (Lstate, 0, LUA_MULTRET, 0);

   return (retval);
}

/****************************************************************************/
/*
*/ 

int WASD_Register (lua_State *Lstate)

{
   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "WASD_Register()\n");



/**
   luaL_openlib (Lstate, "WASD", WASDlib, 1);
**/

/**
   lua_getglobal (Lstate, "WASD");
   if (lua_isnil (Lstate, -1))
   {
      lua_pop (Lstate, 1);
      lua_newtable (Lstate);
      lua_newtable (Lstate);
   }
   luaL_setfuncs (Lstate, WASDlib, 0);
   lua_setglobal (Lstate, "WASD");
**/

   lua_newtable (Lstate);
   luaL_setfuncs (Lstate, WASDlib, 0);
   lua_setglobal (Lstate, "WASD");

   return (1);
}

/****************************************************************************/
/*
*/ 

int WASD_getenv (lua_State *Lstate)

{
   char  *cptr, *sptr;

   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "WASD_getenv()\n");

   if (lua_gettop(Lstate) != 1)
   {
      lua_pushstring (Lstate, WASD_ERROR_ARGNUM);
      lua_error (Lstate);
      return (0);
   }

   if (lua_isstring (Lstate, 1))
      cptr = (char*)lua_tostring (Lstate, 1);
   else
      cptr = "*";

   if (sptr = CgiVar (cptr))
      lua_pushstring (Lstate, sptr);
   else
   if (sptr = getenv (cptr))
      lua_pushstring (Lstate, sptr);
   else
      lua_pushnil (Lstate);

   return (1);
}

/****************************************************************************/
/*
Report error message. Assumes that the error message is on top of the stack.
*/ 

int report (lua_State *Lstate)

{
   /*********/
   /* begin */
   /*********/

   fprintf (stderr, "lua: fatal error: `%s'\n", lua_tostring (Lstate, -1));
   fflush (stderr);
   printf ("Content-type: text/plain\n\n\
Configuration fatal error: see error log!\n");
   printf ("%s\n", lua_tostring(Lstate, -1));
   return (1);
}

/****************************************************************************/
/*
*/ 

int runlua
(
lua_State *Lstate,
char* lua_string
)
{
   int err_func;

   /*********/
   /* begin */
   /*********/

   lua_pushliteral(Lstate, "debug");
//   lua_rawget(Lstate, LUA_GLOBALSINDEX);  /* get traceback function */
   lua_pushliteral(Lstate, "traceback");
   lua_gettable(Lstate, -2);
   err_func = lua_gettop (Lstate);
   return (luaL_loadstring (Lstate, lua_string)) ||
           (lua_pcall (Lstate, 0, LUA_MULTRET, err_func));
}

/*****************************************************************************/
/*
Generate a server call-out (e.g. WATCH: or NOTICED:).
*/

void CallOut
(
char *SourceModule,
int SourceLine,
char *CallOutType,
char *FaoString,
...
)
{
   static char  *CgiPlusEsc = NULL,
                *CgiPlusEot = NULL;

   int  argcnt, status;
   char  *cptr, *sptr, *zptr;
   char  Buffer [16384],
         FaoBuffer [256],
         WhereAt [64];
   unsigned long  *vecptr;
   $DESCRIPTOR (BufferDsc, Buffer);
   $DESCRIPTOR (FaoBufferDsc, FaoBuffer);
   unsigned long  FaoVector [32];
   va_list  argptr;

   /*********/
   /* begin */
   /*********/

   va_count (argcnt);

   sprintf (WhereAt, "%s:%d", SourceModule, SourceLine);

   vecptr = FaoVector;
   if (CallOutType == NULL) *vecptr++ = (unsigned long)WhereAt;
   va_start (argptr, FaoString);
   for (argcnt -= 1; argcnt; argcnt--)
      *vecptr++ = (unsigned long)va_arg (argptr, unsigned long);
   va_end (argptr);

   zptr = (sptr = FaoBuffer) + sizeof(FaoBuffer)-3;
   if (CallOutType == NULL) for (cptr = "|!12AZ|"; *cptr; *sptr++ = *cptr++);
   for (cptr = FaoString; *cptr && sptr < zptr; *sptr++ = *cptr++);
   *sptr++ = '\0';
   FaoBufferDsc.dsc$a_pointer = FaoBuffer;
   FaoBufferDsc.dsc$w_length = sptr - FaoBuffer;
   status = sys$faol (&FaoBufferDsc, 0, &BufferDsc,
                      (unsigned long*)&FaoVector);
   if (!(status & 1)) sprintf (Buffer, "$FAO() %%X%08.08X", status);

   if (!CgiPlusEsc) CgiPlusEsc = getenv("CGIPLUSESC");
   if (!CgiPlusEot) CgiPlusEot = getenv("CGIPLUSEOT");

   fflush (stdout);
   fputs (CgiPlusEsc, stdout);
   fflush (stdout);
   /* the leading '!' indicates we're not going to read the response */
   fprintf (stdout, "!%s: %s", CallOutType ? CallOutType : "WATCH", Buffer);
   fflush (stdout);
   fputs (CgiPlusEot, stdout);
   fflush (stdout);
}

/****************************************************************************/
/*
Read the file contents specified by 'FileName' into memory, set the pointer
at 'FileTextPtr' to the contents and the file size at 'FileSizePtr'.  Returns a
VMS status value that should be checked.
*/ 

int ReadFileIntoMemory
(
char *FileName,
char **FileTextPtr,
int *FileSizePtr
)
{
   int  status,
        Bytes,
        BytesRemaining,
        BufferCount;
   char  *cptr, *sptr,
         *BufferPtr,
         *LinePtr;
   FILE  *FilePtr;
   stat_t  StatBuffer;

   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "ReadFileIntoMemory() |%s|\n", FileName);

   if (FileTextPtr != NULL) *FileTextPtr = NULL;
   if (FileSizePtr != NULL) *FileSizePtr = 0;

   if (stat (FileName, &StatBuffer) < 0)
   {
      status = vaxc$errno;
      if (Debug) fprintf (stdout, "%%X%08.08X\n", status);
      return (status);
   }

   if (StatBuffer.st_fab_rfm == FAB$C_VAR ||
       StatBuffer.st_fab_rfm == FAB$C_VFC)
      FilePtr = fopen (FileName, "r", "shr=put");
   else
      FilePtr = fopen (FileName, "r", "shr=put", "ctx=bin");
   if (FilePtr == NULL)
   {
      status = vaxc$errno;
      return (status);
   }

   Bytes = StatBuffer.st_size;

   /* a little margin for error ;^) */
   BufferPtr = calloc (Bytes+32, 1);
   if (BufferPtr == NULL) return (vaxc$errno);

   BufferCount = 0;

   if (StatBuffer.st_fab_rfm == FAB$C_VAR ||
       StatBuffer.st_fab_rfm == FAB$C_VFC)
   {
      BytesRemaining = Bytes;
      LinePtr = BufferPtr;
      while (fgets (LinePtr, BytesRemaining, FilePtr) != NULL)
      {
         if (!*LinePtr) break;
         for (cptr = LinePtr; *cptr; cptr++);
         BufferCount += cptr - LinePtr;
         BytesRemaining -= cptr - LinePtr;
         LinePtr = cptr;
      }
   }
   else
   {
      status = fread (BufferPtr, Bytes, 1, FilePtr);
      if (status == 1) BufferCount = Bytes;
   }

   fclose (FilePtr);

   if (StatBuffer.st_fab_rfm == FAB$C_STMLF)
   {
      /* text file, newlines only (check first 512 characters and quit) */
      for (cptr = BufferPtr; *cptr && cptr < BufferPtr+512; cptr++)
         if (*(unsigned short*)cptr == '\r\n')
         {
            sptr = cptr;
            while (*cptr)
            {
               if (*(unsigned short*)cptr == '\r\n') cptr++;
               *sptr++ = *cptr++;
            }
            *sptr = '\0';
            BufferCount = sptr - BufferPtr;
            break;
         }
   }

/***
   if (Debug) fprintf (stdout, "%s", BufferPtr);
***/

   if (FileTextPtr != NULL) *FileTextPtr = BufferPtr;
   if (FileSizePtr != NULL) *FileSizePtr = BufferCount;

   return (SS$_NORMAL);
}

/*****************************************************************************/
/*
Return the value of a CGI variable regardless of whether it is used in a
standard CGI environment or a WASD CGIplus (RTE) environment.  Also
automatically switches WASD V7.2 and later servers into 'struct' mode for
significantly improved performance.

WASD by default supplies CGI variables prefixed by "WWW_" to differentiate them
from any other DCL symbols (or "env"ironment logicals).  Lua scripts expect CGI
variables without this.
*/

char* CgiVar (char *VarName)

{
#  ifndef CGIVAR_STRUCT_SIZE
#     define CGIVAR_STRUCT_SIZE 8192
#  endif
#  define SOUS sizeof(unsigned short)

   static int  CalloutDone,
               StructLength;
   static char  *CgiPlusEof,
                *NextVarNamePtr;
   static char  StructBuffer [CGIVAR_STRUCT_SIZE];
   static FILE  *CgiPlusIn;
   
   int  status;
   int  Length;
   char  *bptr, *cptr, *sptr;

   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "CgiVar() |%s|\n", !VarName ? "NULL" : VarName);

   if (!CgiPlusEof) CgiPlusEof = getenv ("CGIPLUSEOF");

   if (VarName)
   {
      /***************************/
      /* return a variable value */
      /***************************/

      if (!CgiPlusEof)
      {
         /* standard CGI environment */
         static char  WwwName [256] = "WWW_";
         static $DESCRIPTOR (NameDsc, WwwName);
         static $DESCRIPTOR (BufferDsc, StructBuffer);
         unsigned short  ShortLength;

         /* by default WASD CGI variable names are prefixed by "WWW_", add */
         strncpy (WwwName+4, VarName, sizeof(WwwName)-5);
         NameDsc.dsc$w_length = strlen(WwwName);
   
         status = lib$get_symbol (&NameDsc, &BufferDsc, &ShortLength, NULL);
         if (status & 1) return (StructBuffer);
         return (NULL);
      }

      /* hmmm, CGIplus not initialized */
      if (!StructLength) return (NULL);

      if (VarName[0] == '*')
      {
         /* return each CGIplus variable in successive calls */
         if (!(Length = *(unsigned short*)NextVarNamePtr))
         {
            NextVarNamePtr = StructBuffer;
            return (NULL);
         }
         sptr = (NextVarNamePtr += SOUS);
         NextVarNamePtr += Length;
         /* by default WASD CGI variable name are prefixed by "WWW_", ignore */
         return (sptr + 4);
      }

      /* return a pointer to this CGIplus variable's value */
      for (bptr = StructBuffer; Length = *(unsigned short*)bptr; bptr += Length)
      {
         /* by default WASD CGI variable name are prefixed by "WWW_", ignore */
         sptr = (bptr += SOUS) + 4;
         for (cptr = VarName; *cptr && *sptr && *sptr != '='; cptr++, sptr++)
            if (toupper(*cptr) != toupper(*sptr)) break;
         /* if found return a pointer to the value */
         if (!*cptr && *sptr == '=') return (sptr + 1);
      }
      /* not found */
      return (NULL);
   }

   if (CgiPlusIn)
   {
      /****************/
      /* end previous */
      /****************/

      fflush (stdout);
      fputs (CgiPlusEof, stdout);
      fflush (stdout);
   }

   /*****************************/
   /* get the CGIplus variables */
   /*****************************/

   /* cannot "sync" in a non-CGIplus environment */
   if (!VarName && !CgiPlusEof) return (NULL);

   /* the CGIPLUSIN stream can be left open */
   if (!CgiPlusIn)
      if (!(CgiPlusIn = fopen (getenv("CGIPLUSIN"), "r")))
         exit (vaxc$errno);

   /* get the starting record (the essentially discardable one) */
   for (;;)
   {
      cptr = fgets (StructBuffer, sizeof(StructBuffer), CgiPlusIn);
      if (!cptr) exit (vaxc$errno);
      /* if the starting sentinal is detected then break */
      if (*(unsigned short*)cptr == '!\0' ||
          *(unsigned short*)cptr == '!\n' ||
          (*(unsigned short*)cptr == '!!' && isdigit(*(cptr+2)))) break;
   }

   /* detect the CGIplus "force" record-mode environment variable (once) */
   if (*(unsigned short*)cptr == '!!')
   {
      /********************/
      /* CGIplus 'struct' */
      /********************/

      /* get the size of the binary structure */
      StructLength = atoi(cptr+2);
      if (StructLength <= 0 || StructLength > sizeof(StructBuffer))
         exit (SS$_BUGCHECK);

      if (!fread (StructBuffer, 1, StructLength, CgiPlusIn))
         exit (vaxc$errno);
   }
   else
   {
      /*********************/
      /* CGIplus 'records' */
      /*********************/

      /* reconstructs the original 'struct'ure from the records */
      sptr = (bptr = StructBuffer) + sizeof(StructBuffer);
      while (fgets (bptr+SOUS, sptr-(bptr+SOUS), CgiPlusIn))
      {
         /* first empty record (line) terminates variables */
         if (bptr[SOUS] == '\n') break;
         /* note the location of the length word */
         cptr = bptr;
         for (bptr += SOUS; *bptr && *bptr != '\n'; bptr++);
         if (*bptr != '\n') exit (SS$_BUGCHECK);
         *bptr++ = '\0';
         if (bptr >= sptr) exit (SS$_BUGCHECK);
         /* update the length word */
         *(unsigned short*)cptr = bptr - (cptr + SOUS);
      }
      if (bptr >= sptr) exit (SS$_BUGCHECK);
      /* terminate with a zero-length entry */
      *(unsigned short*)bptr = 0;
      StructLength = (bptr + SOUS) - StructBuffer;
   }

   if (!CalloutDone)
   {
      /* provide the CGI callout to set CGIplus into 'struct' mode */
      fflush (stdout);
      fputs (getenv("CGIPLUSESC"), stdout);
      fflush (stdout);
      /* the leading '!' indicates we're not going to read the response */
      fputs ("!CGIPLUS: struct", stdout);
      fflush (stdout);
      fputs (getenv("CGIPLUSEOT"), stdout);
      fflush (stdout);
      /* don't need to do this again (the '!!' tells us what mode) */
      CalloutDone = 1;
   }

   WatchScript = (CgiVar("WATCH_SCRIPT") != NULL);

   return ("");

#  undef SOUS
}

/****************************************************************************/