Authen-SASL-Cyrus
view release on metacpan or search on metacpan
/*
# Copyright (c) 2002 Carnegie Mellon University
# Written by Mark Adamson
# with SASL2 support by Leif Johansson
# with better mem management and callbacks by Ulrich Pfeifer
#
# C code to glue Perl SASL to Cyrus libsasl.so
#
*/
#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include <sasl/sasl.h>
#ifdef SASL2
#define SASLCONST const
#define SASL_ERR(x) sasl_errdetail(sasl->conn)
#else
#define SASLCONST
#define SASL_ERR(x) x
#endif
#ifndef SASL_IP_LOCAL
#define SASL_IP_LOCAL 5
#endif
#ifndef SASL_IP_REMOTE
#define SASL_IP_REMOTE 6
#endif
/* Ulrich Pfeifer: Poor man's XPUSH macros for ancient perls. Note that the
stack is extended by a constant 1. That is OK for the uses below, but
insufficient in general */
#ifndef dXSTARG
#undef XPUSHi
#undef XPUSHp
#define XPUSHi(A) \
EXTEND(sp,1); \
PUSHs(sv_2mortal(newSViv(A)));
#define XPUSHp(A,B) \
EXTEND(sp,1); \
PUSHs(sv_2mortal(newSVpvn((char *)(A),(STRLEN)(B))));
#endif
#ifndef SvPV_nolen
#define SvPV_nolen(A) SvPV(A,PL_na)
#endif
struct authensasl {
sasl_conn_t *conn;
sasl_callback_t *callbacks;
char *server;
char *service;
char *mech;
char *user;
char *initstring;
int initstringlen;
SASLCONST char *errormsg;
int code;
};
/* A unique looking number to help PerlCallback() determine which parameter is
the context. Apparently not all callbacks get the context as the first */
#define PERLCONTEXT_MAGIC 0x0001ABCD
struct _perlcontext {
unsigned long magic;
int id;
SV *func;
SV *param;
int intparam;
};
void free_callbacks(struct authensasl *sasl)
{
if (sasl->callbacks) {
Safefree(sasl->callbacks);
Safefree(sasl->callbacks->context);
sasl->callbacks = NULL;
}
}
struct _perlcontext *
alloc_callbacks(struct authensasl *sasl, int count)
{
dTHX;
struct _perlcontext *pcb;
int i;
Newz(23, pcb, count, struct _perlcontext);
if (pcb == NULL) {croak("Out of memory\n");}
for (i=0; i<count; i++) {
pcb[i].magic = PERLCONTEXT_MAGIC;
}
Newz(23, sasl->callbacks, count+1, sasl_callback_t);
if (sasl->callbacks == NULL) {croak("Out of memory\n");}
return(pcb);
}
/*
This is the wrapper function that calls Perl callback functions. The SASL
library needs a C function to handle callbacks, and this function forms the
glue to get from the C library back into Perl. The perlcontext is a wrapper
around the context given to the "callbacks" method. It tells which Perl
function should be called and what parameter to pass it.
Different types of callbacks have different "output" parameters to give data
back to the C library. This function needs to know how to take information
returned from the Perl callback subroutine and load it back into the output
parameters for the C library to read.
Note that if the callback given to the "callbacks" Perl method is really just
a string or integer, there is no need to jump into a Perl subroutine.
The value is loaded directly into the output parameters.
*/
int PerlCallback(void *perlcontext, char *arg0, char *arg1, char *arg2)
{
dTHX;
char *c;
int i, intparam, count, rc=0;
unsigned int len=0;
struct _perlcontext *cp;
sasl_secret_t *pass;
SV *rsv;
cp = (struct _perlcontext *)perlcontext;
/* For SASL_CB_PASS, the context is in the SECOND param */
if ((cp == NULL) || (cp->magic != PERLCONTEXT_MAGIC)) {
cp = (struct _perlcontext *)arg1;
warn("Authen::SASL::Cyrus: PerlCallback called with bad context\n");
}
/* If there is no function to call, just return the "parameter" */
if (cp->func == NULL) {
switch(cp->id) {
case SASL_CB_USER:
case SASL_CB_AUTHNAME:
case SASL_CB_LANGUAGE:
if (cp->param==NULL) rc = -1;
else {
*((char **)arg1) = SvPV(cp->param, len);
if (arg2) *((unsigned *)arg2) = len;
}
break;
case SASL_CB_PASS:
arg1 = SvPV(cp->param, len);
Newc(23, pass, len+sizeof(sasl_secret_t), char, sasl_secret_t);
if (pass == NULL) {
rc = -1;
}
else {
pass->len = len;
Copy(arg1, (char *)pass->data, len, char);
*((sasl_secret_t **)arg2) = pass;
}
break;
default:
break;
}
}
/* If there is a function, call it */
else {
/* Make a new call stack */
dSP;
/* We'll be making temporary perl variables */
}
else if ((value[i] >= '0') && (value[i] <= '9')) {
ip[dotcount+semicolon] = ip[dotcount+semicolon]*10 + (value[i] - '0');
if ((semicolon == 0) && (ip[dotcount] >= 256)) {
break;
}
}
else {
isv2=0;
break;
}
}
if (isv2) {
#ifdef SASL2
strcpy(buf, value);
#else
saddr = (struct sockaddr_in *)buf;
saddr->sin_port = ip[4];
saddr->sin_addr.s_addr = (ip[0] << 24) | (ip[1] << 16) | (ip[2] << 8) | ip[3];
#endif
}
else {
#ifdef SASL2
saddr=(struct sockaddr_in *)value;
memcpy(&addr, &saddr->sin_addr, sizeof(addr));
c = inet_ntoa(addr);
sprintf(buf, "%s;%d", c, saddr->sin_port);
#else
memcpy(buf, value, sizeof(struct sockaddr_in));
#endif
}
}
/* Convert a Perl callback name into a C callback ID */
static
int CallbackNumber(char *name)
{
dTHX;
if (!strcasecmp(name, "user")) return(SASL_CB_USER);
else if (!strcasecmp(name, "auth")) return(SASL_CB_AUTHNAME);
else if (!strcasecmp(name, "language")) return(SASL_CB_LANGUAGE);
else if (!strcasecmp(name, "password")) return(SASL_CB_PASS);
else if (!strcasecmp(name, "pass")) return(SASL_CB_PASS);
croak("Unknown callback: '%s'. (user|auth|language|pass)\n", name);
}
/*
Fill the passed callback action into the passed Perl/SASL callback. This
is called either from ExtractParentCallbacks() when the "new" method is
called, or from callbacks() when that method is called directly.
*/
static
void AddCallback(
char *name,
SV *action,
struct _perlcontext *pcb,
sasl_callback_t *cb
)
{
dTHX;
pcb->id = CallbackNumber(name);
if (SvROK(action)) { /* user => <ref> */
action = SvRV(action);
if (SvTYPE(action) == SVt_PVCV) { /* user => sub { }, user => \&func */
pcb->func = action;
pcb->param = NULL;
}
else if (SvTYPE(action) == SVt_PVAV) { /* user => [ \&func, $param ] */
pcb->func = av_shift((AV *)action);
pcb->param = av_shift((AV *)action);
}
else
croak("Unknown reference parameter to %s callback.\n", name);
}
else if (SvTYPE(action) & SVt_PV) { /* user => $param */
pcb->func = NULL;
pcb->param = action;
}
else if (SvTYPE(action) & SVt_IV) { /* user => 1 */
pcb->func = NULL;
pcb->param = NULL;
pcb->intparam = SvIV(action);
}
else
croak("Unknown parameter to %s callback.\n", name);
/* Write the C SASL callback */
cb->id = pcb->id;
cb->proc = PerlCallback;
if (cb->id == SASL_CB_PASS) {
cb->proc = PerlPassCallback;
}
else {
cb->proc = PerlCallback;
}
cb->context = pcb;
}
/*
Take the callback stored in the parent object and install them into the
current *sasl object. This is called from the "new" method.
*/
static
void ExtractParentCallbacks(SV *parent, struct authensasl *sasl)
{
dTHX;
char *key;
int count=0;
long l;
struct _perlcontext *pcb;
SV **hashval, *val;
HV *hash=NULL;
HE *iter;
/* Make sure parent is a ref to a hash (with keys like "mechanism"
and "callback") */
if (!parent) return;
if (!SvROK(parent)) return;
if (SvTYPE(SvRV(parent)) != SVt_PVHV) return;
hash = (HV *)SvRV(parent);
/* Get the parent's callbacks */
hashval = hv_fetch(hash, "callback", 8, 0);
if (!hashval || !*hashval) return;
val = *hashval;
/* Parent's callbacks are another hash (with keys like "user" and "auth") */
if (!SvROK(val)) return;
if (SvTYPE(SvRV(val)) != SVt_PVHV) return;
hash = (HV *)SvRV(val);
/* Run through all of parent's callback types, counting them */
hv_iterinit(hash);
for (iter=hv_iternext(hash); iter; iter=hv_iternext(hash)) count++;
/* Allocate space for the callbacks */
free_callbacks(sasl);
pcb = alloc_callbacks(sasl, count);
/* Run through all of parent's callback types, fill in the sasl->callbacks */
hv_iterinit(hash);
for (count=0,iter=hv_iternext(hash); iter; iter=hv_iternext(hash),count++){
key = hv_iterkey(iter, &l);
val = hv_iterval(hash, iter);
AddCallback(key, val, &pcb[count], &sasl->callbacks[count]);
}
sasl->callbacks[count].id = SASL_CB_LIST_END;
sasl->callbacks[count].context = NULL;
return;
}
MODULE=Authen::SASL::Cyrus PACKAGE=Authen::SASL::Cyrus
struct authensasl *
client_new(pkg, parent, service, host, ...)
char *pkg
SV *parent
char *service
char *host
CODE:
{
const char *mech=NULL;
SASLCONST char *init=NULL;
unsigned int initlen=0;
struct authensasl *sasl;
HV *hash;
SV **hashval, *val;
sasl_security_properties_t ssp;
sasl = Newz(23, sasl, 1, struct authensasl);
if (sasl == NULL) croak("Out of memory\n");
if (!host || !*host) {
if (!sasl->errormsg) sasl->errormsg = "Need a 'hostname' in client_new()";
}
else
sasl->server = savepv(host);
if (!service || !*service) {
if (!sasl->errormsg) sasl->errormsg = "Need a 'service' name in client_new()";
}
else
sasl->service = savepv(service);
/* Extract callback info from the parent object */
ExtractParentCallbacks(parent, sasl);
/* Extract mechanism info from the parent object */
if (parent && SvROK(parent) && (SvTYPE(SvRV(parent)) == SVt_PVHV)) {
hash = (HV *)SvRV(parent);
hashval = hv_fetch(hash, "mechanism", 9, 0);
if (hashval && *hashval && SvTYPE(*hashval) == SVt_PV) {
if (sasl->mech) Safefree(sasl->mech);
sasl->mech = savepv(SvPV_nolen(*hashval));
}
}
sasl_client_init(NULL);
#ifdef SASL2
sasl->code = sasl_client_new(sasl->service, sasl->server, 0, 0, sasl->callbacks, 1, &sasl->conn);
#else
sasl->code = sasl_client_new(sasl->service, sasl->server, sasl->callbacks, 1, &sasl->conn);
#endif
if (sasl->code != SASL_OK) {
if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_client_new failed");
}
else {
#ifdef SASL2
sasl->code = sasl_client_start(sasl->conn, sasl->mech, NULL, &init, &initlen, &mech);
#else
sasl->code = sasl_client_start(sasl->conn, sasl->mech, NULL, NULL, &init, &initlen, &mech);
#endif
if (sasl->code == SASL_NOMECH) {
if (!sasl->errormsg)
sasl->errormsg = "No mechanisms available (did you set all needed callbacks?)";
}
else if ((sasl->code != SASL_OK) && (sasl->code != SASL_CONTINUE)) {
if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_client_start failed");
}
else {
#ifdef SASL2
memset(&ssp, 0, sizeof(ssp));
ssp.maxbufsize = 0xFFFF;
ssp.max_ssf = 0xFF;
sasl_setprop(sasl->conn, SASL_SEC_PROPS, &ssp);
#endif
if (init) {
New(23, sasl->initstring, initlen, char);
if (sasl->initstring) {
memcpy(sasl->initstring, init, initlen);
sasl->initstringlen = initlen;
}
else {
sasl->code = SASL_FAIL;
if (!sasl->errormsg) sasl->errormsg = "Out of memory in client_new()";
sasl->initstringlen = 0;
}
}
}
}
RETVAL = sasl;
}
OUTPUT:
RETVAL
char *
client_start(sasl)
struct authensasl *sasl
PPCODE:
{
XPUSHp(sasl->initstring, sasl->initstringlen);
}
char *
client_step(sasl, instring)
struct authensasl *sasl
char *instring
PPCODE:
{
SASLCONST char *outstring=NULL;
unsigned int inlen, outlen=0;
if (sasl->errormsg) {
XSRETURN_EMPTY;
}
SvPV(ST(1),inlen);
unsigned int inlen, outlen=0;
if (sasl->errormsg) {
XSRETURN_UNDEF;
}
instring = SvPV(ST(1),inlen);
sasl->code = sasl_encode(sasl->conn, instring, inlen, &outstring, &outlen);
if (sasl->code != SASL_OK) {
if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_encode failed");
XSRETURN_UNDEF;
}
XPUSHp(outstring, outlen);
}
char *
decode(sasl, instring)
struct authensasl *sasl
char *instring
PPCODE:
{
SASLCONST char *outstring=NULL;
unsigned int inlen, outlen=0;
if (sasl->errormsg) {
XSRETURN_UNDEF;
}
instring = SvPV(ST(1),inlen);
sasl->code = sasl_decode(sasl->conn, instring, inlen, &outstring, &outlen);
if (sasl->code != SASL_OK) {
if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_decode failed");
XSRETURN_UNDEF;
}
XPUSHp(outstring, outlen);
}
int
callback(sasl, ...)
struct authensasl *sasl
CODE:
{
SV *action;
char *name;
int x, count;
struct _perlcontext *pcb;
/* Asking if a given callback exists */
if (items == 2) {
RETVAL = 0;
if (sasl->callbacks) {
name = SvPV_nolen(ST(1));
x = CallbackNumber(name);
/* Check the installed callbacks for the requested ID */
for (count=0; sasl->callbacks[count].id != SASL_CB_LIST_END; count++) {
if (sasl->callbacks[count].id == x) {
RETVAL = 1;
break;
}
}
}
}
else {
/* Prepare space for the callback list */
free_callbacks(sasl);
count = (items - 1) / 2;
pcb = alloc_callbacks(sasl, count);
/* Fill in the callbacks */
for(x=0; x<count; x++) {
/* Convert the callback name into a SASL ID number */
if (SvTYPE(ST(1+x*2)) != SVt_PV) {
croak("callbacks: Unknown key given in position %d\n", x);
}
name = SvPV_nolen(ST(1+x*2));
action = ST(2+x*2);
AddCallback(name, action, &pcb[x], &sasl->callbacks[x]);
}
sasl->callbacks[count].id = SASL_CB_LIST_END;
sasl->callbacks[count].context = NULL;
RETVAL = count;
}
}
OUTPUT:
RETVAL
int
saslversion(sasl)
struct authensasl *sasl
CODE:
#ifdef SASL2
RETVAL=2;
#else
RETVAL=1;
#endif
OUTPUT:
RETVAL
char *
error(sasl)
struct authensasl *sasl
CODE:
RETVAL = (char *)sasl->errormsg;
sasl->errormsg = NULL;
OUTPUT:
RETVAL
int
code(sasl)
struct authensasl *sasl
CODE:
RETVAL=sasl->code;
OUTPUT:
RETVAL
SV *
diag(sasl)
struct authensasl *sasl
CODE:
if (sasl->errormsg) {
RETVAL = sv_2mortal(newSVpv((char *)sasl->errormsg, 0));
}
else {
RETVAL = &PL_sv_undef;
}
OUTPUT:
RETVAL
char *
break;
#ifdef SASL2
case SASL_IPLOCALPORT:
case SASL_IPREMOTEPORT:
XPUSHp( (char *)value, strlen((char *)value));
break;
#else
case SASL_IP_LOCAL:
case SASL_IP_REMOTE:
XPUSHp( (char *)value, sizeof(struct sockaddr_in));
break;
#endif
default:
XPUSHi(-1);
}
XSRETURN(1);
}
/* Fill in the properties */
for(x=1; x<items; x+=2) {
prop = ST(x);
value = (void *)SvPV( ST(x+1), proplen );
if (SvTYPE(prop) == SVt_IV) {
propnum = SvIV(prop);
}
else if (SvTYPE(prop) == SVt_PV) {
name = SvPV_nolen(prop);
propnum = PropertyNumber(name);
}
switch(propnum){
case SASL_IPLOCALPORT:
case SASL_IPREMOTEPORT:
case SASL_IP_LOCAL:
case SASL_IP_REMOTE:
SASLIPuser2lib(buf, (char *)value, proplen);
value = buf;
break;
default:
break;
}
sasl->code = sasl_setprop(sasl->conn, propnum, value);
if (sasl->code != SASL_OK) {
if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_setprop failed");
RETVAL = 1;
}
}
}
void
DESTROY(sasl)
struct authensasl *sasl
CODE:
if (sasl->conn) sasl_dispose(&sasl->conn);
free_callbacks(sasl);
if (sasl->service) Safefree(sasl->service);
if (sasl->mech) Safefree(sasl->mech);
#ifndef SASL2
if (sasl->errormsg) Safefree(sasl->errormsg);
#endif
if (sasl->initstring)Safefree(sasl->initstring);
Safefree(sasl);
( run in 1.061 second using v1.01-cache-2.11-cpan-39bf76dae61 )