/* --------------------------------------------------------------- */
/* Publish current directory to an FTP-driven web server           */
/* --------------------------------------------------------------- */
/*                                                                 */
/* Copyright (c) Mike Cowlishaw, 2006-2013.  All rights reserved.  */
/* Parts Copyright (c) IBM, 2006-2010.                             */
/*                                                                 */
/* Permission to use, copy, modify, and distribute this software   */
/* for any non-commercial purpose without fee is hereby granted,   */
/* provided that the above copyright notice and this permission    */
/* notice appear in all copies, and that notice and the date of    */
/* any modifications be added to the software.                     */
/*                                                                 */
/* This software is provided "as is".  No warranties, whether      */
/* express, implied, or statutory, including, but not limited to,  */
/* implied warranties of merchantability and fitness for a         */
/* particular purpose apply to this software.  The author shall    */
/* not, in any circumstances, be liable for special, incidental,   */
/* or consequential damages, for any reason whatsoever.            */
/*                                                                 */
/* --------------------------------------------------------------- */
/*                                                                 */
/* This updates current directory and (by default) subdirectories. */
/* It is intended that this be called by a 'stub' Rexx program     */
/* that provides a simple command-line interface; see              */
/* demoPublish.rex for an example.                                 */
/*                                                                 */
/* Arguments:                                                      */
/*                                                                 */
/*   Arg1 is the FTP address of the target top-level directory,    */
/*        e.g, 'homepages.freds.co.uk/buss'                        */
/*   Arg2 is user and password (separated by ':'), e.g., 'foo:bar' */
/*   Arg3 is list of extensions to transfer as text (a string, one */
/*        word per extension, e.g., 'html txt asc')                */
/*   Arg4 is list of extensions to ignore (these types will not be */
/*        published), e.g., log bak old                            */
/*   Arg5 is list to send as binary (use '*' to send all not in    */
/*        the other two lists), e.g., zip exe msi apk jpg          */
/*   Arg6 is "effective command line":                             */
/*          verb [flags]                                           */
/*        where 'verb' is a (required) pseudonym and 'flags' may   */
/*        be any (or none) of the user flags/keywords:             */
/*          clean        - delete server files not found in the    */
/*                         curent directory                        */
/*          first        - update first difference only            */
/*          force        - force update (rewrite) of all files     */
/*          from name    - skip creates and updates until the file */
/*                         matching 'name' is reached              */
/*          logfile file - set the (qualified) name for FTP log    */
/*                         to 'file'                               */
/*          noisy        - display FTP commands during run         */
/*          nolog        - do not write FTP trace log              */
/*          nopublog     - do not write publish timestamp log      */
/*          only name    - publish just the one file 'name'        */
/*          top          - update top-level directory only         */
/*          trace        - switch on Rexx (debug) tracing          */
/*          help, /?, ?, -? -- display help                        */
/*        e.g., sgpublish clean noisy                              */
/*        'name' or 'file' cannot contain blanks [sorry]           */
/*   Arg7 is directory to start in (unchanged if not given or '')  */
/*        [fully qualified, as from directory() call]              */
/*   Arg8 is notification list; any number of service assignments  */
/*        of the form service=data, where data depend on the       */
/*        service; only a summary message is sent, not page/file   */
/*        details.                                                 */
/*        Supported services and data formats:                     */
/*          none                                                   */
/*        No longer supported:                                     */
/*          twitter=user:password     [requires sendtwit.rex]      */
/*                                                                 */
/*   returns '' if OK, non-empty message if a problem              */
/*                                                                 */
/* ::requires "rxftp.cls"                                          */
/* --------------------------------------------------------------- */
-- 2006.03.23 Initial derived from sgpublish, demonpublish, www2publish
-- 2007.03.15 Add total size count
-- 2007.04.30 Convert to use RxFtp class (ooRexx) & Linuxify
-- 2007.10.30 Add HTML check (warning) for img without alt or size
-- 2008.01.20 Log to m: preferably (on Windows)
-- 2009.04.0x Add from, first, and only options
-- 2009.07.12 Add start directory arg
-- 2009.07.16 Add logfile option
-- 2009.11.27 Add notifications option
-- 2013.05.07 Review and cleanup

parse arg server'/'where, user':'password,,
          textTypes, ignoretypes, binarytypes,,
          command flags, startdir, notifications
signal on novalue

delim='\'                -- filesystem delimiter
parse upper source os .
if left(os, 3)\='WIN' then delim='/'


help=0                   -- display help text
clean=0                  -- delete unmatched files
first=0                  -- update first difference only
fromname=''              -- name to start from
skipping=0               -- set when skippng creates and updates
force=0                  -- force all files to be updated
top=0                    -- 1=top level only
trace=0                  -- turn on Rexx tracing
noisy=0                  -- turn on FTP command tracing
pubfile='publish.log'    -- where to log publish timestamps
created=0                -- counts
updated=0                -- ..
ignored=0                -- ..
deleted=0                -- ..
total=0                  -- ..
indent=0                 -- nesting indication
totalsize=0              -- total size of files (calculated locally)
logging=1                -- log to file
loggedon=0               -- 1 if session needs logoff
logpub=1                 -- write publish timestamps
logname=command'.log'    -- default log name

if delim='\' then do
  -- use m: disk if available, otherwise c:
  if exists('m:\web') then logdisk='m'
                      else logdisk='c'
  logroot=logdisk':\'              -- where to log FTP trace
  end
 else                              -- *x
  logroot='~/'                     -- where to log FTP trace
logfile=logroot||logname           -- default log place

shared='session server user password logfile logging rc clean force top trace',
       'created updated ignored deleted total today thisbase months indent',
       'binarytypes texttypes ignoretypes totalsize noisy delim',
       'command first fromname skipping loggedon'

-- Check parameters
rc=0
msg=''
do while flags\=''
  parse var flags flag flags
  arg=translate(flag)
  select
    when arg='CLEAN'    then clean=1
    when arg='FIRST'    then first=1
    when arg='FORCE'    then force=1
    when arg='FROM'     then do
      if fromname\='' then call quit 'FROM or ONLY specified twice'
      parse var flags fromname flags
      if fromname='' then call quit 'No FROM name specified'
      say 'Skipping creates and updates until:' fromname
      skipping=1
      end
    when arg='LOGFILE'  then do
      parse var flags logfile flags
      if logfile='' then call quit 'No LOGFILE name specified'
      say 'Logging to' logfile
      end
    when arg='NOLOG'    then logging=0
    when arg='NOPUBLOG' then logpub=0
    when arg='TRACE'    then trace=1
    when arg='NOISY'    then noisy=1
    when arg='ONLY'     then do         -- same as FIRST FROM name
      if fromname\='' then call quit 'FROM or ONLY specified twice'
      parse var flags fromname flags
      if fromname='' then call quit 'No ONLY name specified'
      say 'Updating or creating only:' fromname
      skipping=1
      first=1
      end
    when arg='TOP'      then top=1
    when arg='?'        then help=1
    when arg='/?'       then help=1
    when arg='-?'       then help=1
    when arg='HELP'     then help=1
    otherwise
      msg='Unknown parameter:' flag
      say msg
      say ''
      help=1
      rc=-1
    end
  end  -- do while flags

-- Display help and exit if asked for
if help then call help msg

-- check vitals
if server=''   then call quit 'No server specified'
if where=''    then call quit 'No path specified'
if user=''     then call quit 'No user specified'
if password='' then call quit 'No password specified'

-- Date constants
months='Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec'
parse value date('s') with thisyyyy +4 thismm +2 thisdd +2
-- say thisyyyy':'thismm':'thisdd
today = (thismm-1)*31 + thisdd
thisbase=thisyyyy*372+today                  -- pseudo base for today

-- check and set local starting directory
if startdir\='' then do
  if \isdir(startdir) then
    call quit 'Invalid starting directory:' startdir
  call directory startdir
  say 'Using directory:' directory()
  end
topdir=directory()                           -- remember where started

-- Create an FTP session object
session=.rxftp~new()

-- Start logging and/or tracing
if noisy then rc=session~FtpTrace            -- noisy tracing for debug
if logging then do
  call sysfiledelete logfile
  rc=session~FtpTraceLog(logfile, 'R')
  if rc\=0 then say '(Could not write to trace file:' logfile')'
  end
if trace then trace r

rc=session~FtpSetUser(server, user, password)
if rc=-1 then do
  ftperrno=session~ftperrno
  if ftperrno='FTPLOGIN' then call quit 'Could not login user ['user']'
  if ftperrno='FTPHOST' then call quit 'Could not connect to server ['server']'
  if ftperrno='FTPCONNECT' then call quit 'Server not responding ['server']'
  call quit 'Could not set user ['ftperrno']'
  end

say 'FTP to' server 'as' user'...'
loggedon=1

-- change to the correct directory at server
rc=session~FtpChDir(where)
if rc=-1 then do              -- directory not exist?
  say '"'where'" does not exist on the server.  Creating...'
  rc=session~FtpMkDir(where)
  if rc=-1 then call quit 'Could not create directory "'where'"'
  rc=session~FtpChDir(where)  -- change to new directory
  if rc=-1 then call quit 'Unexpected error from second FtpChDir'
  end

-- at this point we are in the right [top] place on server and locally
here=directory()         -- remember where we are
s=lastpos(delim, here)
dir=substr(here, s+1)
if dir='' then call quit 'Unexpected directory() response:' here

say '  ...' dir '...'
call updatedir '.'       -- from here on down (quits if error)
call directory here

call cleanup             -- end FTP session

record=thisyyyy':'thismm':'thisdd left(time(),5),
       'Created' created', updated' updated','
if clean then record=record 'deleted' deleted','

totalmb=format(totalsize/(1024*1024),,1)'MB'
record=record 'ignored' ignored', total' total', size' totalmb
say record
if logpub then do
  call lineout pubfile, record
  call lineout pubfile
  end

if notifications\='' then do
  top=filespec('n', topdir)
  m=''
  if created>0 then m=m 'created' created','
  if updated>0 then m=m 'updated' updated','
  if deleted>0 then m=m 'deleted' deleted','
  if m='' then say '(nothing to notify)'
   else do
    m=space(m)
    -- remove trailing comma; add time & date so not a duplicate
    m=left(m, length(m)-1) 'at' time() 'on' date('s',,,'-')
    message='Files in "'top'" have been changed ('m')'

    do while notifications\=''
      parse var notifications assign notifications
      parse var assign service'='data
      service=upper(service)
      select
        when service='FOOBAR' then nop
        /***
        when service='TWITTER' then do
          parse var data user':'
          hashtag='#'user'/'top
          call sendtwit data message hashtag
          end
        ***/
        otherwise say 'Unknown notification service:' service
        end
      end -- notifications loop
    end -- notification to make
  end -- notifications

exit ''                  -- (UpdateDir worked)


/* ------------------------------------------------------------------ */
/* Display help and exit with message                                 */
/* ------------------------------------------------------------------ */
help: procedure expose (shared)
  parse arg msg
  h.1 ='Use as: ' command '[clean] [force] [top]'
  h.2 =''
  h.3 ='This updates the "'server'" server, user "'user'", with'
  h.4 ='the files from the current directory (which must be known to'
  h.5 ='the' command 'command).'
  h.6 =''
  h.7 ='Only the filetypes in one of the lists:'
  h.8 ='  binaryTypes:' binarytypes
  h.9 ='or'
  h.10='  textTypes:' texttypes
  h.11='are published; only files that are new, or are newer or same day'
  h.12='as existing files are published (unless "force" is specified in'
  h.13='which case all are updated).'
  h.14=''
  h.15='If "clean" is specified then files found on the server but not in'
  h.16='the current directory are deleted.'
  h.17='If "top" is specified, only the top-level directory is updated.'
  h.18=''
  h.19='If "from name" is specified, creates and updates are skipped'
  h.20='until the named file is found.  "first" will stop after the'
  h.21='first create or update. "only name" is the same as "first from name".'
  h.22=''
  h.23='Call with "?", "/?", "-?", or "help" to display this help text'
  h.24=''
  h.25='Please see' command'.txt for more details'
  h.0 =25  -- number of lines

  say
  do i=1 to h.0
    say h.i
    end i
  exit msg

/* ------------------------------------------------------------------ */
/* Terminate if error, with rc                                        */
/* ------------------------------------------------------------------ */
quit: procedure expose (shared)
  say arg(1) '[rc='rc']       -- program exiting.'
  say 'Please contact MFC for help.'
  call cleanup
  exit arg(1)

/* ------------------------------------------------------------------ */
/* Cleanup session                                                    */
/* ------------------------------------------------------------------ */
cleanup: procedure expose (shared)
  if symbol('session')\='LIT' then do
    if loggedon then rc=session~FtpLogOff -- 'quit' to server
    if logging  then rc=session~FtpTraceLogOff -- end logging
    -- if noisy then rc=session~FtpTrace -- [cannot be switched off]
    end
  return

/* ------------------------------------------------------------------ */
/* Check an HTML file                                                 */
/* ------------------------------------------------------------------ */
checkhtml: procedure expose (shared)
  parse arg file
  doc=charin(file, 1, chars(file))
  call lineout file                     -- or put will fail
  do forever
    parse var doc '<img' atts'>' doc
    if atts='' then leave
    -- have an img tag to check
    up=translate(atts)
    if pos('SRC=', up)=0 then say '*** <img> with no SRC= in:' file
    if pos('ALT=', up)=0 then say '*** <img' atts'> has no ALT= in:' file
     else do
      parse var up 'ALT=' text .
      if text='""' then say '*** <img' atts'> has empty ALT= in:' file
      end
    if pos('WIDTH=', up)=0 then say '*** <img' atts'> has no WIDTH= in:' file
     else if pos('HEIGHT=', up)=0 & pos('DEPTH=', up)=0 then
       say '*** <img' atts'> has no HEIGHT= in:' file
    -- [don't warn about both width and height]
    end
  return

/* ------------------------------------------------------------------ */
/* Update subdirectory                                                */
/*   Arg1 is the name of the subdirectory to update                   */
/*                                                                    */
/* This is first called with "subdirectory" name '.' to update the    */
/* top level directory, and then calls itself recursively to update   */
/* subdirectories (unless TOP is specified)                           */
/*                                                                    */
/* Exits directly to Quit if an error.                                */
/* ------------------------------------------------------------------ */
updatedir: procedure expose (shared)
  parse arg subdir

  indent=indent+2             -- formatting
  para=copies(' ', indent)

  -- change to correct directory at server and locally
  if subdir\='.' then do
    rc=session~FtpChDir(subdir)
    if rc=-1 then do          -- directory not exist?
      say '"'subdir'" does not exist on the server.  Creating...'
      rc=session~FtpMkDir(subdir)
      if rc=-1 then call quit 'Could not create directory "'subdir'"'
      rc=session~FtpChDir(subdir)     -- change to new directory
      if rc=-1 then call quit 'Unexpected error from second sub FtpChDir' subdir
      end

    call directory subdir     -- locally, too
    say para'...' subdir '...'
    end

  -- We are in the right place.  Find out what's there.
  rc=session~FtpDir('*.*')
  if rc=-1 then call quit 'Unexpected error from FtpDir *.*'
  -- if address()='GOSERVE' then say '  Back from FTPDir' -- temp

  -- note that on some servers we get some spurious blank lines, and
  -- in one case (old 10quid system) have seen all files listed twice

  -- Copy oo-response items to there. stem to use old code
  there.0=session~response~items
  do i=1 to there.0
    there.i=session~response[i]
    end i
  if address()='GOSERVE' then 'active read' there.0*50  -- estimate is fine

  -- parse the files.  We are only interested in relative age to the
  -- nearest day, so we work out 'pseudo ages' based on 32-day months

  -- say para||there.0 'files...'
  exist.=0       -- file exists
  fileage.=372   -- assume age of any surprising file is 1 year (31*12)
  do f=1 to there.0
    parse var there.f flags . . . size mon dd year name
    if name='' then iterate                  -- spurious from some servers
    if left(flags, 1)\='-' then iterate      -- ignore directory & messes
    if pos('->', name)>0 then iterate        -- a symbolic link
    exist.name=1                             -- have file
    -- calculate an approximate age, assuming 31 days/month
    mm=wordpos(mon, months)                  -- month name to number
    if mm=0 then iterate                     -- use default
    if \datatype(dd, 'n') then iterate       -- ..
    if dd<1 | dd>31 then iterate             -- ..
    -- the 'year' field will be a time if within a year
    if \datatype(year, 'n') then do          -- is not a year
      days=today - ((mm-1)*31+dd)            -- age in days
      if days<0 then days=372+days           -- [future date]
      end
     else
      days=thisbase-(year*372+(mm-1)*31+dd)
    fileage.name=days                        -- save
    -- say para||name 'is' days 'days old'
    end f

  -- now process local files
  localexist.=0       -- local file exists
  call sysfiletree '*', 'LOCAL', 'BL'
  if result\=0 then call quit 'Unexpected SysFileTree error ['result']'

  -- say para'-----'

  dir.=''                -- delay list for directories
  dirs=0                 -- count of delayed directories
  do f=1 to local.0
    -- say '>>' local.f
    parse var local.f yyyy'-'mm'-'dd' ' . size flags fullname
    name=filespec('name', fullname)
    -- record for later if a directory
    if left(flags, 2)='-D' then do
      dirs=dirs+1
      dir.dirs=name
      iterate
      end
    -- ignore it if a 'zeroed' or empty file
    if size=0 then iterate
    -- ignore it if type not in a list, or no type (extension)
    d=lastpos('.', name)
    if d=0 then iterate
    type=substr(name, d+1)

    binpos=wordpos(type, binarytypes)
    ascpos=wordpos(type, texttypes)
    if binpos=0 & binarytypes\='*' then      -- not in binary list ..
     if ascpos=0 then do                     -- .. or ascii list
      ignpos=wordpos(type, ignoretypes)
      if ignpos=0 then                       -- worth a warning
        say para'Ignored:' name '(type ".'type'" not known)'
      ignored=ignored+1
      iterate
      end

    /* File is to be sent (created or updated); check it if HTML */
    ishtml=(left(translate(type), 3)='HTM')

    totalsize=totalsize+size                 -- total eligible files' size
    if ascpos>0 then mode='Ascii'
                else mode='Binary'
    localexist.name=1
    total=total+1
    if \exist.name then do    -- new
      if skipping then do
        if translate(fromname)=translate(name) then skipping=0
        end
      if skipping then nop -- say para'Skipped:' name
       else do
        if ishtml then call checkhtml name
        call checksize name
        rc=session~FtpPut(name, name, mode)
        if rc=-1 then call quit 'Unexpected error from create FtpPut' name mode
        say para'Created:' name
        created=created+1
        end
      end
     else do                  -- exists, maybe update
      -- estimated age of local in days
      days=thisbase-(yyyy*372+(mm-1)*31+dd)
      -- say para'Local' name 'is' days 'days old'
      if days<=fileage.name | force then do
        if skipping then do
          if translate(fromname)=translate(name) then skipping=0
          end
        if skipping then nop -- say para'Skipped:' name
         else do
          if ishtml then call checkhtml name
          call checksize name
          rc=session~FtpPut(name, name, mode)
          if rc=-1 then call quit 'Unexpected error from update FtpPut' name mode
          say para'Updated:' name
          updated=updated+1
          end
        end
      end
    if address()='GOSERVE' then 'active sent' size -- still active
    if first & (created+updated>0) then leave f
    end f

  if clean then do            -- any deletes?
    do f=1 to there.0
      parse var there.f flags . . . . . . . name
      if name='' then iterate                -- spurious from some servers
      if left(flags, 1)\='-' then iterate    -- ignore directory & messes
      if pos('->', name)>0 then iterate      -- a symbolic link
      if localexist.name then iterate        -- not missing
      rc=session~FtpDelete(name)
      if rc=-1 then call quit 'Unexpected error from FtpDelete' name
      say para'Deleted:' name
      deleted=deleted+1
      if address()='GOSERVE' then 'active sent' length(name) -- estimate is fine
      end f
    end -- clean

  -- now process nested directories, unless top-level only or first
  -- and completed
  if \top then
   if \(first & (created+updated>0)) then
    do d=1 to dirs
    call updatedir dir.d      -- recursively update from 'name' down
    end d

  if subdir\='.' then do      -- we went down
    call directory '..'       -- up locally
    rc=session~FtpChDir('..') -- and remotely
    if rc=-1 then call quit 'Unexpected error from FtpChDir ".." (parent)'
    end
  indent=indent-2
  return


/* Test whether a name is a directory that exists */
isdir: procedure
  parse arg dir
  r=right(dir, 1)
  if r='/' | r='\' then dir=left(dir, length(dir)-1)
  opts='BL'                             -- not subdirs
  call sysfiletree dir, 'LIST', opts
  if result\=0 then return result
  if list.0\=1 then return 0
  parse var list.1 date time size flags fullname
  return pos('D', flags)=2              -- is directory

/* Note large file start */
checksize: procedure expose para
  parse arg name
  size=stream(name, 'c', 'query size')
  if size<250000 then return
  mb=format(size/1024**2,,1)
  say para'Putting:' name ' ['mb 'MB]'
  return


::requires "rxftp.cls"