/*
 *
 * Copyright (c) 1994-2008 Carnegie Mellon University.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 *
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in
 *    the documentation and/or other materials provided with the
 *    distribution.
 *
 * 3. The name "Carnegie Mellon University" must not be used to
 *    endorse or promote products derived from this software without
 *    prior written permission. For permission or any legal
 *    details, please contact
 *      Carnegie Mellon University
 *      Center for Technology Transfer and Enterprise Creation
 *      4615 Forbes Avenue
 *      Suite 302
 *      Pittsburgh, PA  15213
 *      (412) 268-7393, fax: (412) 268-7395
 *      innovation@andrew.cmu.edu
 *
 * 4. Redistributions of any form whatsoever must retain the following
 *    acknowledgment:
 *    "This product includes software developed by Computing Services
 *     at Carnegie Mellon University (http://www.cmu.edu/computing/)."
 *
 * CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO
 * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
 * AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE
 * FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
 * AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
 * OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 * $Id: IMAP.xs,v 1.29 2010/01/06 17:01:55 murch Exp $
 */

/*
 * Perl interface to the Cyrus imclient routines.  This enables the
 * use of Perl to implement Cyrus utilities, in particular imtest and cyradm.
 */

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <pwd.h>
#include <unistd.h>

#include "imclient.h"
#include "imapurl.h"
#include "util.h"
#include "xmalloc.h"

#include "cyrperl.h"
#include "config.h"

typedef struct xscyrus *Cyrus_IMAP;

/* Perl pre-5.6.0 compatibility */
#ifndef aTHX_
#define aTHX_
#endif

/*
 * This is the code from xsutil.c
 */

/* hack, since libcyrus apparently expects fatal() to exist */
void fatal(const char *s, int exit)
{
  croak(s);
}

/*
 * Decrement the refcounts of the Perl SV's in the passed rock, then free the
 * rock.  This cleans up a callback.
 */

void imclient_xs_callback_free(struct xsccb *rock)
{
  struct xscb *xcb;

  if (rock) {
    /* find the destructor-cleanup version and nuke its record */
    for (xcb = rock->client->cb; xcb; xcb = xcb->next) {
      if (xcb->rock == rock) break;
    }
    if (xcb) {
      if (xcb->prev)
	xcb->prev->next = xcb->next;
      else
	rock->client->cb = xcb->next;
      if (xcb->next) xcb->next->prev = xcb->prev;
      if (xcb->name) safefree(xcb->name);
      safefree(xcb);
    }
    /* if (rock->pcb) SvREFCNT_dec(rock->pcb); */
    /* if (rock->prock) SvREFCNT_dec(rock->prock); */
    safefree(rock);
  }
}

/*
 * Invoke a Perl callback on behalf of a Cyrus callback.  This requires some
 * silliness to adapt what we're passed to Perl conventions; specifically,
 * the reply struct becomes a hash (passed as a list).
 */

void imclient_xs_cb(struct imclient *client, void *prock,
		    struct imclient_reply *reply)
{
  dSP;
  SV* rv;
  struct xsccb *rock = (struct xsccb *) prock;

  /* push our args onto Perl's stack */
  ENTER;
  SAVETMPS;
  PUSHMARK(SP);
  XPUSHs(sv_2mortal(newSVpv("-client", 0)));
  rv = newSVsv(&sv_undef);
  sv_setref_pv(rv, NULL, (void *) rock->client);
  XPUSHs(rv);
  if (rock->prock != &sv_undef) {
    XPUSHs(sv_2mortal(newSVpv("-rock", 0)));
    XPUSHs(sv_mortalcopy(rock->prock));
  }
  XPUSHs(sv_2mortal(newSVpv("-keyword", 0)));
  XPUSHs(sv_2mortal(newSVpv(reply->keyword, 0)));
  XPUSHs(sv_2mortal(newSVpv("-text", 0)));
  XPUSHs(sv_2mortal(newSVpv(reply->text, 0)));
  if (reply->msgno != -1) {
    char tmp[100];
    XPUSHs(sv_2mortal(newSVpv("-msgno", 0)));
    sprintf(tmp,"%ld",reply->msgno);
    XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
  }
  PUTBACK;
  /* invoke Perl */
  perl_call_sv(rock->pcb, G_VOID|G_DISCARD);
  FREETMPS;
  SPAGAIN;
  LEAVE;
  /* clean up */
  if (rock->autofree) imclient_xs_callback_free(rock);
}

/*
 * Callback used when ::_send is invoked without a callback.  The "prock" is an
 * AV, which is set to the contents of the imclient_reply; this is detected in
 * ::_send, which is calling imclient_processoneevent() repeatedly.  (This
 * simulates a non-callback-based invocation, for trivial clients.)
 */
void imclient_xs_fcmdcb(struct imclient *client, void *prock,
			struct imclient_reply *reply)
{
  AV *av;
  struct xsccb *rock = (struct xsccb *) prock;

  /* SvREFCNT_dec(SvRV(rock->prock)); */
  SvRV(rock->prock) = (SV *) (av = newAV());
  /* sv_setsv(rock->prock, sv_2mortal(newRV_inc((SV *) (av = newAV())))); */
  av_push(av, sv_2mortal(newSVpv(reply->keyword, 0)));
  av_push(av, sv_2mortal(newSVpv(reply->text, 0)));
  if (reply->msgno != -1) av_push(av, sv_2mortal(newSViv(reply->msgno)));
  /* clean up */
  if (rock->autofree) imclient_xs_callback_free(rock);
}

static int get_username(void *context, int id,
			const char **result, unsigned *len) {
  Cyrus_IMAP text = (Cyrus_IMAP)context;
  if(id == SASL_CB_AUTHNAME) {
	if(len) *len = strlen(text->authname);
	*result = text->authname;
	return SASL_OK;
  } else if (id == SASL_CB_USER) {
	if(text->username) {
	    if(len) *len = strlen(text->username);
	    *result = text->username;
	} else {
	    if(len) *len = 0;
	    *result = "";
	}
	return SASL_OK;
  } 
  return SASL_FAIL;
}

static int get_password(sasl_conn_t *conn, void *context, int id,
			sasl_secret_t **psecret) {
  Cyrus_IMAP text = (Cyrus_IMAP)context;
  if(id != SASL_CB_PASS) return SASL_FAIL;
  if(!text->password) {
	char *ptr;
	/* Using fprintf because printf won't flush under perl 5.8.0 for some
	 * reason */ 
	fprintf(stdout, "Password: ");
	fflush(stdout);
	ptr = cyrus_getpass("");
	text->password = safemalloc(sizeof(sasl_secret_t) + strlen(ptr));
	text->password->len = strlen(ptr);
	strncpy((char *) text->password->data, ptr, text->password->len);
  }
  *psecret = text->password;
  return SASL_OK;  
}

/* callbacks we support */
static const sasl_callback_t sample_callbacks[NUM_SUPPORTED_CALLBACKS] = {
  { SASL_CB_USER, get_username, NULL }, 
  { SASL_CB_AUTHNAME, get_username, NULL }, 
  { SASL_CB_PASS, get_password, NULL },
  { SASL_CB_LIST_END, NULL, NULL }
};

MODULE = Cyrus::IMAP	PACKAGE = Cyrus::IMAP
PROTOTYPES: ENABLE

int
CONN_NONSYNCLITERAL()
CODE:
	RETVAL = IMCLIENT_CONN_NONSYNCLITERAL;
OUTPUT:
	RETVAL

int
CONN_INITIALRESPONSE()
CODE:
	RETVAL = IMCLIENT_CONN_INITIALRESPONSE;
OUTPUT:
	RETVAL

int
CALLBACK_NUMBERED()
CODE:
	RETVAL = CALLBACK_NUMBERED;
OUTPUT:
	RETVAL

int
CALLBACK_NOLITERAL()
CODE:
	RETVAL = CALLBACK_NOLITERAL;
OUTPUT:
	RETVAL

MODULE = Cyrus::IMAP	PACKAGE = Cyrus::IMAP	PREFIX=imclient_
PROTOTYPES: ENABLE

SV *
imclient_new(class, host = "localhost", port = 0, flags = 0)
	char *class;
	char *host
	char *port
	int flags;
PREINIT:
	struct imclient *client;
	int rc;
	SV *bang;
	Cyrus_IMAP rv;
	int i;
CODE:
	/* Allocate and setup the return value */
	rv = safemalloc(sizeof *rv);

	rv->authenticated = 0;

	memcpy(rv->callbacks, sample_callbacks, sizeof(sample_callbacks));

	/* Setup respective contexts */
	for(i=0; i < NUM_SUPPORTED_CALLBACKS; i++) {
	    rv->callbacks[i].context = rv;
	}

	/* Connect */
	rc = imclient_connect(&client, host, port, rv->callbacks);
	switch (rc) {
	case -1:
	  Perl_croak(aTHX_ "imclient_connect: unknown host \"%s\"", host);
	  safefree(rv);
	  break;
	case -2:
	  Perl_croak(aTHX_ "imclient_connect: unknown service \"%s\"", port);
	  safefree(rv);
	  break;
	case 0:
	  if (client) {
	    rv->class = safemalloc(strlen(class) + 1);
	    strcpy(rv->class, class);
	    rv->username = rv->authname = NULL;
	    rv->password = NULL;
	    rv->imclient = client;
	    imclient_setflags(client, flags);
	    rv->flags = flags;
	    rv->cb = 0;
	    rv->cnt = 1;
	    break;
	  }
	  /*FALLTHROUGH*/
	default:
	  bang = perl_get_sv("^E", TRUE);
	  sv_setiv(bang, rc);
	  XSRETURN_UNDEF;
	}
	ST(0) = sv_newmortal();
	/* fprintf(stderr, "!NEW %p %s\n", rv, class); */
	sv_setref_pv(ST(0), class, (void *) rv);

void
imclient_DESTROY(client)
	Cyrus_IMAP client
PREINIT:
	struct xscb *nx;
CODE:
/* fprintf(stderr, "!DESTROY %p %d\n", client, client->cnt); */
	if (!client->cnt--) {
/* printf("closing\n"); */
	  imclient_close(client->imclient);
	  while (client->cb) {
	    nx = client->cb->next;
	    if (client->cb->name) safefree(client->cb->name);
	    /* if (client->cb->rock->pcb) SvREFCNT_dec(client->cb->rock->pcb); */
	    /* if (client->cb->rock->prock) SvREFCNT_dec(client->cb->rock->prock); */
	    safefree(client->cb->rock);
	    client->cb = nx;
	  }
	  safefree(client->password);
	  safefree(client->class);
	  safefree(client);
	}

void
imclient_setflags(client, flags)
	Cyrus_IMAP client
	int flags
PPCODE:
	imclient_setflags(client->imclient, flags);
	client->flags |= flags;

void
imclient_clearflags(client, flags)
	Cyrus_IMAP client
	int flags
PPCODE:
	imclient_clearflags(client->imclient, flags);
	client->flags &= ~flags;

int
imclient_flags(client)
	Cyrus_IMAP client
PPCODE:
	/* why is there no way to query this? */
	RETVAL = client->flags;

char *
imclient_servername(client)
	Cyrus_IMAP client
PREINIT:
	char *cp;
CODE:
	cp = imclient_servername(client->imclient);
	RETVAL = cp;
OUTPUT:
	RETVAL

void
imclient_processoneevent(client)
	Cyrus_IMAP client
PPCODE:
	imclient_processoneevent(client->imclient);

SV *
imclient__authenticate(client, mechlist, service, user, auth, password, minssf, maxssf)
	Cyrus_IMAP client
	char* mechlist
	char* service
	char* user
	char* auth
	char* password
	int minssf
	int maxssf
PREINIT:
	int rc;
CODE:
	ST(0) = sv_newmortal();

	if(client->authenticated) {
	  ST(0) = &sv_no;
	  return;
	}

	/* If the user parameter is undef, set user to be NULL */
	if(!SvOK(ST(3))) user = NULL;
	if(!SvOK(ST(5))) password = NULL;

	client->username = user; /* AuthZid */
	client->authname = auth; /* Authid */

	if(password) {
	    if(client->password) safefree(client->password);
	    client->password =
		safemalloc(sizeof(sasl_secret_t) + strlen(password));
	    client->password->len = strlen(password);
	    strncpy((char *) client->password->data, password, client->password->len);
	}

	rc = imclient_authenticate(client->imclient, mechlist, service, user,
				   minssf, maxssf);
	if (rc)
	  ST(0) = &sv_no;
	else {
	  client->authenticated = 1;
	  ST(0) = &sv_yes;
	}

int
imclient_havetls()
CODE:
#ifdef HAVE_SSL
	RETVAL = 1;
#else
	RETVAL = 0;
#endif /* HAVE_SSL */
OUTPUT:
	RETVAL

SV *
imclient__starttls(client, tls_cert_file, tls_key_file, CAfile, CApath)
	Cyrus_IMAP client
	char* tls_cert_file
	char* tls_key_file
        char* CAfile
        char* CApath
PREINIT:
	int rc;
CODE:
	ST(0) = sv_newmortal();

	/* If the tls_{cert, key}_file parameters are undef, set to be NULL */
	if(!SvOK(ST(2))) tls_cert_file = NULL;
	if(!SvOK(ST(3))) tls_key_file = NULL;
#ifdef HAVE_SSL
	rc = imclient_starttls(client->imclient, tls_cert_file, tls_key_file, CAfile, CApath);
	if (rc)
	  ST(0) = &sv_no;
	else {
	  ST(0) = &sv_yes;
	}
#else
	ST(0) = &sv_no;
#endif /* HAVE_SSL */

void
imclient_addcallback(client, ...)
	Cyrus_IMAP client
PREINIT:
	int arg;
	HV *cb;
	char *keyword;
	STRLEN klen;
	int flags;
	SV **val;
	SV *pcb;
	SV *prock;
	struct xsccb *rock;
	struct xscb *xcb;
PPCODE:
	/*
	 * $client->addcallback(\%cb[, ...]);
	 *
	 * where %cb is:
	 *
	 * -trigger => 'OK' (or 'NO', etc.)
	 * -flags => CALLBACK_NOLITERAL|CALLBACK_NUMBERED (optional)
	 * -callback => \&sub or undef (optional)
	 * -rock => SV, reference or undef (optional)
	 *
	 * this is moderately complicated because the callback is a Perl ref...
	 */
	for (arg = 1; arg < items; arg++) {
	  if (!SvROK(ST(arg)) || SvTYPE(SvRV(ST(arg))) != SVt_PVHV)
	    Perl_croak(aTHX_ "addcallback: arg %d not a hash reference", arg);
	  cb = (HV *) SvRV(ST(arg));
	  /* pull callback crud */
	  if (((val = hv_fetch(cb, "-trigger", 8, 0)) ||
	       (val = hv_fetch(cb, "Trigger", 7, 0))) &&
	      SvTYPE(*val) == SVt_PV)
	    keyword = SvPV(*val, klen);
	  else
	    Perl_croak(aTHX_ "addcallback: arg %d missing trigger", arg);
	  if ((((val = hv_fetch(cb, "-flags", 6, 0)) ||
		 (val = hv_fetch(cb, "Flags", 5, 0)))))
	  {	
	    flags = SvIV(*val);
          } else {
            flags = 0;
          }

	  if (((val = hv_fetch(cb, "-callback", 9, 0)) ||
	       (val = hv_fetch(cb, "Callback", 8, 0))) &&
	      ((SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVCV) ||
	       SvTYPE(*val) == SVt_PV))
	    pcb = *val;
	  else
	    pcb = 0;
	  if ((val = hv_fetch(cb, "-rock", 5, 0)) ||
	      (val = hv_fetch(cb, "Rock", 4, 0)))
	    prock = *val;
	  else
	    prock = &sv_undef;
	  /*
	   * build our internal rock, which is used by our internal
	   * callback handler to invoke the Perl callback
	   */
	  if (!pcb)
	    rock = 0;
	  else {
	    rock = (struct xsccb *) safemalloc(sizeof *rock);
	    /* bump refcounts on these so they don't go away */
	    rock->pcb = SvREFCNT_inc(pcb);
	    if (!prock) prock = &sv_undef;
	    rock->prock = SvREFCNT_inc(prock);
	    rock->client = client;
	    rock->autofree = 0;
	  }
	  /* and add the resulting callback */
	  imclient_addcallback(client->imclient, keyword, flags,
			       (pcb ? imclient_xs_cb : 0), rock, 0);
	  /* update the callback list, possibly freeing old callback info */
	  for (xcb = client->cb; xcb; xcb = xcb->next) {
	    if (xcb->name && strcmp(xcb->name, keyword) == 0 &&
		xcb->flags == flags)
	      break;
	  }
	  if (xcb) {
	    if (xcb->rock->pcb) SvREFCNT_dec(xcb->rock->pcb);
	    if (xcb->rock->prock) SvREFCNT_dec(xcb->rock->prock);
	    safefree(xcb->rock);
	  }
	  else if (pcb) {
	    xcb = (struct xscb *) safemalloc(sizeof *xcb);
	    xcb->prev = 0;
	    xcb->name = safemalloc(strlen(keyword) + 1);
	    strcpy(xcb->name, keyword);
	    xcb->flags = flags;
	    xcb->next = client->cb;
	    client->cb = xcb;
	  }
	  if (pcb)
	    xcb->rock = rock;
	  else if (xcb) {
	    if (xcb->prev)
	      xcb->prev->next = xcb->next;
	    else
	      client->cb = xcb->next;
	    if (xcb->next) xcb->next->prev = xcb->prev;
	    safefree(xcb->name);
	    safefree(xcb);
	  }
	}
	
void
imclient__send(client, finishproc, finishrock, str)
	Cyrus_IMAP client
	SV *finishproc
	SV *finishrock
	char *str
PREINIT:
	STRLEN arg;
	SV *pcb;
	SV *prock;
	struct xscb *xcb;
	struct xsccb *rock;
	char *cp, *dp, *xstr;
PPCODE:
	/*
	 * The C version does escapes.  It also does varargs, which I would
	 * much rather not have to reimplement in XS code; so that is done in
	 * Perl instead.  (The minus being that I have to track any changes
	 * to the C API; but it'll be easier in Perl than in XS.)
	 *
	 * We still have to do the callback, though.
	 *
	 * @@@ the Perl code can't do synchronous literals
	 */
	if (SvROK(finishproc) && SvTYPE(SvRV(finishproc)) == SVt_PVCV)
	  pcb = SvRV(finishproc);
	else
	  pcb = 0;
	if (!pcb)
	  prock = sv_2mortal(newRV_inc(&PL_sv_undef));
	else if (finishrock)
	  prock = finishrock;
	else
	  prock = sv_2mortal(newSVsv(&PL_sv_undef));
	/*
	 * build our internal rock, which is used by our internal
	 * callback handler to invoke the Perl callback
	 */
	rock = (struct xsccb *) safemalloc(sizeof *rock);
        /* bump refcounts on these so they don't go away */
	if (!pcb) pcb = sv_2mortal(newSVsv(&PL_sv_undef));
	rock->pcb = pcb;
	if (!prock) prock = sv_2mortal(newSVsv(&PL_sv_undef));
	rock->prock = prock;
	rock->client = client;
	rock->autofree = 1;
	/* register this callback so it can be gc'ed properly (pointless?) */
	xcb = (struct xscb *) safemalloc(sizeof *xcb);
	xcb->prev = 0;
	xcb->name = 0;
	xcb->flags = 0;
	xcb->rock = rock;
	xcb->next = client->cb;
	client->cb = xcb;
	/* protect %'s in the string, since the caller does the dirty work */
	arg = 0;
	for (cp = str; *cp; cp++)
	  if (*cp == '%') arg++;
	xstr = safemalloc(strlen(str) + arg + 1);
	dp = xstr;
	for (cp = str; *cp; cp++) {
	  *dp++ = *cp;
	  if (*cp == '%') *dp++ = *cp;
	}
	*dp = 0;
	/* and do it to it */
	imclient_send(client->imclient,
		      (SvTRUE(pcb) ?
		       imclient_xs_cb :
		       imclient_xs_fcmdcb),
		      (void *) rock, xstr);
	safefree(xstr);
	/* if there was no Perl callback, spin on events until finished */
	if (!SvTRUE(pcb)) {
	  AV *av;
	  while (SvTYPE(SvRV(prock)) != SVt_PVAV) {
	    PUTBACK;
	    imclient_processoneevent(client->imclient);
	    SPAGAIN;
	  }
	  /* push the result; if scalar, stuff text in $@ */
	  av = (AV *) SvRV(prock);
	  if (GIMME_V == G_SCALAR) {
	    EXTEND(SP, 1);
	    pcb = av_shift(av);
	    if (strcmp(SvPV(pcb, arg), "OK") == 0)
	      PUSHs(&sv_yes);
	    else
	      PUSHs(&sv_no);
	    pcb = perl_get_sv("@", TRUE);
	    sv_setsv(pcb, av_shift(av));
	    if (av_len(av) != -1) {
	      pcb = perl_get_sv("^E", TRUE);
	      sv_setsv(pcb, av_shift(av));
	    }
	  } else {
	    EXTEND(SP, av_len(av) + 1);
	    PUSHs(av_shift(av));
	    PUSHs(av_shift(av));
	    if (av_len(av) != -1) PUSHs(av_shift(av));
	  }
	  /* and free it */
	  /* SvREFCNT_dec(prock); */
	}

void
imclient_getselectinfo(client)
	Cyrus_IMAP client
PREINIT:
	int fd, writep;
PPCODE:
	imclient_getselectinfo(client->imclient, &fd, &writep);
	/*
	 * should this return a glob?  (evil, but would solve a nasty issue
	 * in &send()...)
	 *
	 * also, should this check for scalar context and complain?
	 */
	EXTEND(SP, 2);
	PUSHs(sv_2mortal(newSViv(fd)));
	if (writep)
	  PUSHs(&sv_yes);
	else
	  PUSHs(&sv_no);

void
imclient_fromURL(client,url)
	Cyrus_IMAP client
	char *url
PREINIT:
	struct imapurl imapurl;
PPCODE:
	imapurl_fromURL(&imapurl, url);

	if(!imapurl.server || !imapurl.mailbox) {
		safefree(imapurl.freeme);
		XSRETURN_UNDEF;
	}

	XPUSHs(sv_2mortal(newSVpv(imapurl.server, 0)));
	XPUSHs(sv_2mortal(newSVpv(imapurl.mailbox, 0)));

	/* newSVpv copies the above */
	safefree(imapurl.freeme);
	
	XSRETURN(2);

void
imclient_toURL(client,server,box)
	Cyrus_IMAP client
	char *server
	char *box
PREINIT:
	char *out_buf;
	int len;
	struct imapurl imapurl;
PPCODE:
	len = strlen(server)+strlen(box);
	out_buf = safemalloc(4*len);

	memset(&imapurl, 0, sizeof(struct imapurl));
	imapurl.server = server;
	imapurl.mailbox = box;
	imapurl_toURL(out_buf, &imapurl);

	if(!out_buf[0]) {
		safefree(out_buf);
		XSRETURN_UNDEF;
	}

	XPUSHs(sv_2mortal(newSVpv(out_buf, 0)));

	/* newSVpv copies this */
	safefree(out_buf);
	
	XSRETURN(1);
