# correo_smtp.4gl - envio de correo por SMTP directo con base.Channel.
# Sin autenticacion SMTP (relay por IP), sin TLS. Asume que el servidor
# anuncia 8BITMIME. Uso libre: copialo y adaptalo, sin garantia.

IMPORT os
IMPORT util
IMPORT security

CONSTANT SMTP_HOST   = "smtp.ejemplo.com"
CONSTANT SMTP_PORT   = 25
CONSTANT EHLO_NOMBRE = "servidor-app.ejemplo.com"
CONSTANT TIMEOUT_SEG = 60
CONSTANT MAX_BYTES   = 26214400 -- 25 MB entre todos los adjuntos
CONSTANT CHARSET     = "UTF-8"  -- tiene que ser el charset del locale de la aplicacion

PUBLIC TYPE t_correo RECORD
  remitente     STRING,
  destinatarios STRING, -- separados por coma
  cc            STRING,
  bcc           STRING,
  asunto        STRING,
  cuerpo        STRING
END RECORD

PUBLIC FUNCTION correo_enviar(p_correo t_correo, p_adjuntos DYNAMIC ARRAY OF STRING) RETURNS BOOLEAN
  DEFINE ch      base.Channel
  DEFINE l_ok    BOOLEAN
  DEFINE l_total BIGINT
  DEFINE i       INTEGER

  IF NOT (sin_saltos(p_correo.remitente) AND sin_saltos(p_correo.destinatarios)
      AND sin_saltos(p_correo.cc) AND sin_saltos(p_correo.bcc)) THEN
    RETURN FALSE
  END IF

  LET l_total = 0
  FOR i = 1 TO p_adjuntos.getLength()
    LET l_total = l_total + os.Path.size(p_adjuntos[i])
  END FOR
  IF l_total > MAX_BYTES THEN
    RETURN FALSE
  END IF

  LET ch = base.Channel.create()
  TRY
    CALL ch.openClientSocket(SMTP_HOST, SMTP_PORT, "ub", 15)
  CATCH
    RETURN FALSE
  END TRY

  TRY
    LET l_ok = dialogo(ch, p_correo, p_adjuntos)
  CATCH
    LET l_ok = FALSE
  END TRY
  CALL ch.close()
  RETURN l_ok
END FUNCTION

# Cada RETURN FALSE sale sin enviar; quien llama cierra el canal siempre.
PRIVATE FUNCTION dialogo(ch base.Channel, p_correo t_correo, p_adjuntos DYNAMIC ARRAY OF STRING) RETURNS BOOLEAN
  DEFINE l_boundary STRING
  DEFINE l_quit     BOOLEAN
  DEFINE i          INTEGER

  IF NOT comando(ch, NULL) THEN RETURN FALSE END IF -- saludo 220
  IF NOT comando(ch, "EHLO " || EHLO_NOMBRE) THEN RETURN FALSE END IF
  IF NOT comando(ch, SFMT("MAIL FROM:<%1>", p_correo.remitente)) THEN RETURN FALSE END IF

  -- El sobre SMTP es quien entrega: un RCPT TO por direccion, Bcc incluido
  IF NOT rcpt_to(ch, p_correo.destinatarios) THEN RETURN FALSE END IF
  IF NOT rcpt_to(ch, p_correo.cc) THEN RETURN FALSE END IF
  IF NOT rcpt_to(ch, p_correo.bcc) THEN RETURN FALSE END IF

  IF NOT comando(ch, "DATA") THEN RETURN FALSE END IF -- 354

  -- Cabeceras: lo que ve el destinatario. Bcc no se escribe nunca.
  LET l_boundary = "=_" || security.RandomGenerator.CreateUUIDString()
  CALL linea(ch, "From: " || p_correo.remitente)
  CALL linea(ch, "To: " || p_correo.destinatarios)
  IF NOT vacio(p_correo.cc) THEN
    CALL linea(ch, "Cc: " || p_correo.cc)
  END IF
  CALL linea(ch, SFMT("Subject: =?%1?B?%2?=", CHARSET, util.Strings.base64EncodeFromString(p_correo.asunto)))
  CALL linea(ch, "Date: " || fecha_rfc5322())
  CALL linea(ch, SFMT("Message-ID: <%1@ejemplo.com>", security.RandomGenerator.CreateUUIDString()))
  CALL linea(ch, "MIME-Version: 1.0")
  CALL linea(ch, SFMT("Content-Type: multipart/mixed; boundary=\"%1\"", l_boundary))
  CALL linea(ch, "")

  CALL escribir_cuerpo(ch, p_correo.cuerpo, l_boundary)
  FOR i = 1 TO p_adjuntos.getLength()
    CALL escribir_adjunto(ch, p_adjuntos[i], l_boundary)
  END FOR
  CALL linea(ch, "--" || l_boundary || "--")

  IF NOT comando(ch, ".") THEN RETURN FALSE END IF -- 250: correo aceptado
  LET l_quit = comando(ch, "QUIT") -- el correo ya esta aceptado: no se mira
  RETURN TRUE
END FUNCTION

# Escribe una linea con CRLF. Con "ub", writeLine solo pone LF en UNIX y
# Windows no la convierte: el CR va siempre a mano. Ojo: "" es NULL en
# Genero y NULL || "\r" es NULL, asi que la linea vacia se trata aparte;
# si no, saldria solo LF justo en el separador cabeceras/cuerpo.
PRIVATE FUNCTION linea(ch base.Channel, p_texto STRING)
  IF p_texto IS NULL THEN
    CALL ch.writeLine("\r")
  ELSE
    CALL ch.writeLine(p_texto || "\r")
  END IF
END FUNCTION

# Envia un comando (o nada, si es NULL) y lee la respuesta completa.
# TRUE si el codigo es < 400 (2xx y 354).
PRIVATE FUNCTION comando(ch base.Channel, p_texto STRING) RETURNS BOOLEAN
  DEFINE l_resp   STRING
  DEFINE l_codigo INTEGER

  IF p_texto IS NOT NULL THEN
    CALL linea(ch, p_texto)
    -- En modo "u" writeLine() se queda en el bufer: sin flush() el
    -- comando no sale y dataAvailable() espera una respuesta que no llega
    CALL ch.flush()
  END IF
  WHILE TRUE
    IF NOT esperar_datos(ch) THEN
      RETURN FALSE
    END IF
    LET l_resp = ch.readLine()
    IF l_resp IS NULL OR l_resp.getLength() < 3 THEN
      RETURN FALSE
    END IF
    -- "250-..." sigue la respuesta, "250 ..." es la ultima linea
    IF l_resp.getLength() < 4 OR l_resp.getCharAt(4) <> "-" THEN
      EXIT WHILE
    END IF
  END WHILE
  LET l_codigo = l_resp.subString(1, 3)
  RETURN (l_codigo < 400)
END FUNCTION

# readLine() no tiene timeout: si el servidor se calla sin cerrar el
# socket, se queda colgado. Se sondea dataAvailable() con un limite.
PRIVATE FUNCTION esperar_datos(ch base.Channel) RETURNS BOOLEAN
  DEFINE l_limite DATETIME YEAR TO SECOND

  LET l_limite = CURRENT YEAR TO SECOND + TIMEOUT_SEG UNITS SECOND
  WHILE NOT ch.dataAvailable()
    IF CURRENT YEAR TO SECOND >= l_limite THEN
      RETURN FALSE
    END IF
    SLEEP 1
  END WHILE
  RETURN TRUE
END FUNCTION

PRIVATE FUNCTION rcpt_to(ch base.Channel, p_lista STRING) RETURNS BOOLEAN
  DEFINE tok base.StringTokenizer
  DEFINE l_dir STRING

  IF vacio(p_lista) THEN
    RETURN TRUE
  END IF
  LET tok = base.StringTokenizer.create(p_lista, ",")
  WHILE tok.hasMoreTokens()
    LET l_dir = tok.nextToken().trim()
    IF l_dir.getLength() > 0 THEN
      IF NOT comando(ch, SFMT("RCPT TO:<%1>", l_dir)) THEN
        RETURN FALSE
      END IF
    END IF
  END WHILE
  RETURN TRUE
END FUNCTION

PRIVATE FUNCTION escribir_cuerpo(ch base.Channel, p_cuerpo STRING, p_boundary STRING)
  DEFINE tok base.StringTokenizer
  DEFINE l_lin STRING

  CALL linea(ch, "--" || p_boundary)
  CALL linea(ch, SFMT("Content-Type: text/plain; charset=%1", CHARSET))
  CALL linea(ch, "Content-Transfer-Encoding: 8bit")
  CALL linea(ch, "")
  -- createExt con TRUE: create() descarta los tokens vacios y el
  -- correo perderia las lineas en blanco
  LET tok = base.StringTokenizer.createExt(p_cuerpo, "\n", NULL, TRUE)
  WHILE tok.hasMoreTokens()
    LET l_lin = tok.nextToken()
    -- dot-stuffing: una linea que empieza por "." se duplica, o el
    -- servidor podria tomar "." sola como fin del mensaje
    IF l_lin.getCharAt(1) == "." THEN
      LET l_lin = "." || l_lin
    END IF
    CALL linea(ch, l_lin)
  END WHILE
END FUNCTION

# base64 en lineas de 76 (RFC 2045). Ninguna empieza por "." porque el
# alfabeto base64 no tiene punto: aqui no hace falta dot-stuffing.
PRIVATE FUNCTION escribir_adjunto(ch base.Channel, p_ruta STRING, p_boundary STRING)
  DEFINE l_b64    STRING
  DEFINE l_nombre STRING
  DEFINE i, l_fin INTEGER

  LET l_nombre = util.Strings.base64EncodeFromString(os.Path.baseName(p_ruta))
  CALL linea(ch, "--" || p_boundary)
  CALL linea(ch, SFMT("Content-Type: application/octet-stream; name=\"=?%1?B?%2?=\"", CHARSET, l_nombre))
  CALL linea(ch, "Content-Transfer-Encoding: base64")
  CALL linea(ch, SFMT("Content-Disposition: attachment; filename=\"=?%1?B?%2?=\"", CHARSET, l_nombre))
  CALL linea(ch, "")
  LET l_b64 = util.Strings.base64Encode(p_ruta)
  FOR i = 1 TO l_b64.getLength() STEP 76
    -- subString() devuelve NULL si el final pasa del largo: se recorta
    LET l_fin = i + 75
    IF l_fin > l_b64.getLength() THEN
      LET l_fin = l_b64.getLength()
    END IF
    CALL linea(ch, l_b64.subString(i, l_fin))
  END FOR
END FUNCTION

# RFC 5322 en UTC: evita calcular el horario de verano a mano, y
# util.Datetime.format no tiene %z para la zona. Dias y meses en ingles,
# como pide el RFC.
PRIVATE FUNCTION fecha_rfc5322() RETURNS STRING
  DEFINE l_utc DATETIME YEAR TO SECOND
  DEFINE l_dia DATE
  DEFINE l_dias, l_meses STRING
  DEFINE l_d, l_m INTEGER

  LET l_dias  = "SunMonTueWedThuFriSat"
  LET l_meses = "JanFebMarAprMayJunJulAugSepOctNovDec"
  LET l_utc = util.Datetime.toUTC(CURRENT YEAR TO SECOND)
  LET l_dia = l_utc
  LET l_d = WEEKDAY(l_dia) * 3 + 1
  LET l_m = (MONTH(l_dia) - 1) * 3 + 1
  RETURN SFMT("%1, %2 %3 %4 +0000",
    l_dias.subString(l_d, l_d + 2),
    util.Datetime.format(l_utc, "%d"),
    l_meses.subString(l_m, l_m + 2),
    util.Datetime.format(l_utc, "%Y %H:%M:%S"))
END FUNCTION

# Una direccion con CR o LF permitiria inyectar comandos SMTP (en MAIL
# FROM / RCPT TO) o cabeceras nuevas. El asunto no corre ese riesgo:
# viaja en base64.
PRIVATE FUNCTION sin_saltos(p_s STRING) RETURNS BOOLEAN
  IF p_s IS NULL THEN
    RETURN TRUE
  END IF
  RETURN (p_s.getIndexOf("\r", 1) == 0 AND p_s.getIndexOf("\n", 1) == 0)
END FUNCTION

PRIVATE FUNCTION vacio(p_s STRING) RETURNS BOOLEAN
  RETURN (p_s IS NULL OR p_s.trim().getLength() == 0)
END FUNCTION