Authen-SASL-XS
view release on metacpan or search on metacpan
=head1 NAME
Authen::SASL::XS - XS code to glue Perl SASL to Cyrus SASL
=head1 SYNOPSIS
use Authen::SASL;
my $sasl = Authen::SASL->new(
mechanism => 'NAME',
callback => { NAME => VALUE, NAME => VALUE, ... },
);
my $conn = $sasl->client_new(<service>, <server>, <iplocalport>, <ipremoteport>);
my $conn = $sasl->server_new(<service>, <host>, <iplocalport>, <ipremoteport>);
=head1 DESCRIPTION
SASL is a generic mechanism for authentication used by several
network protocols. B<Authen::SASL::XS> provides an implementation
framework that all protocols should be able to share.
The XS framework makes calls into the existing libsasl.so resp. libsasl2
shared library to perform SASL client connection functionality, including
loading existing shared library mechanisms.
=head1 CONSTRUCTOR
The constructor may be called with or without arguments. Passing arguments is
just a short cut to calling the C<mechanism> and C<callback> methods.
You have to use the C<Authen::SASL> new-constructor to create a SASL object.
The C<Authen::SASL> object then holds all necessary variables and callbacks, which
you gave when creating the object.
C<client_new> and C<server_new> will retrieve needed information from this
object.
=cut
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#ifdef SASL2
#include <sasl/sasl.h>
#else
#include <sasl.h>
#endif
// Debugging stuff
//#define PERL_SASL_DEBUG
#ifdef PERL_SASL_DEBUG
#define _DEBUG(x,...) { printf("DEBUG: %s:%d: ",__FUNCTION__, __LINE__); printf(x, __VA_ARGS__); printf("\n"); }
#define __DEBUG(x) _DEBUG(x,NULL);
#else
#define _DEBUG(x,...)
#define __DEBUG(x)
#endif
#define SASL_IS_SERVER 0
#define SASL_IS_CLIENT 1
struct authensasl {
sasl_conn_t *conn;
sasl_callback_t *callbacks;
int callback_count;
char *server;
char *service;
char *mech;
char *user;
int error_code;
char *additional_errormsg;
int is_client;
};
typedef struct authensasl * Authen_SASL_XS;
struct _perlcontext {
SV *func;
SV *param;
int intparam;
};
/* Define missing DEFINES, to help programmers avoiding conflict
* between SASL v1 and v2 libs.
* Ignore but allow setting callbacks which are lib version depending
*/
#ifdef SASL2
#define SASL_CB_SERVER_GETSECRET (0)
#define SASL_CB_SERVER_PUTSECRET (0)
#else
#define SASL_CB_SERVER_USERDB_CHECKPASS (0)
#define SASL_CB_SERVER_USERDB_SETPASS (0)
#define SASL_CB_CANON_USER (0x8007)
#define SASL_CU_AUTHID (0x01)
#define SASL_CU_AUTHZID (0x02)
/* Simulation canon_user Callback in SASL1 */
struct _perlcontext *sp_canon = NULL;
#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
// internal method for handling errors and their messages
int SetSaslError(Authen_SASL_XS sasl,int code, const char* msg)
{
if (sasl == NULL)
#ifdef SASL2
code = SASL_NOTINIT;
#else
code = SASL_FAIL;
#endif
else
{
_DEBUG("former error: %s, Code: %d",sasl->additional_errormsg,
sasl->error_code);
// Do not overwrite Error which are not handled yet, except this one which
// aren't errors at all
if (sasl->error_code == SASL_OK ||
sasl->error_code == SASL_CONTINUE )
{
sasl->error_code = code;
if (sasl->additional_errormsg != NULL)
free(sasl->additional_errormsg);
// Is there a message and is it really an error, otherwise ignore message
if (msg != NULL &&
code != SASL_OK &&
code != SASL_CONTINUE)
sasl->additional_errormsg = strdup(msg);
else
sasl->additional_errormsg = NULL;
}
_DEBUG("called Error: %s, Code: %d Client: %d",msg,code,sasl->is_client);
_DEBUG("now Error: %s, Code: %d",sasl->additional_errormsg,sasl->error_code);
}
return code;
}
/*
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.
*/
/*
This function executes the perl sub/code and returns the result
and its length.
*/
int PerlCallbackSub (struct _perlcontext *cp, char **result, STRLEN *len, AV *args)
{
int rc = SASL_OK;
int count;
SV *rsv;
if (result == NULL)
return SASL_FAIL;
if (*result != NULL)
free(*result);
if (len == NULL)
return SASL_FAIL;
__DEBUG("Callback Callback");
if (cp->func == NULL) // No perl function given, but a value
{
if (cp->param == NULL)
rc = SASL_FAIL;
else {
_DEBUG("PV: %s",SvPV(cp->param,*len));
*result = strdup(SvPV(cp->param,*len));
}
}
else // Call the perl function
{
/* Make a new call stack */
dSP;
/* We'll be making temporary perl variables */
ENTER ;
SAVETMPS ;
PUSHMARK(SP);
if (cp->param)
XPUSHs( cp->param );
// Push all other args from Array Args
if (args != NULL)
while (av_len(args) >= 0)
XPUSHs(av_pop(args));
PUTBACK ;
count = call_sv(cp->func, G_SCALAR);
/* Refresh the local stack in case the function played with it */
SPAGAIN;
_DEBUG("Count of retvals: %d",count);
args = newAV();
av_push(args, newSVpv(auth_identity,0));
av_push(args, newSVpv(requested_user,0));
rc = PerlCallbackSub(cp,&c,&len,args);
av_clear(args);
av_undef(args);
*user = strndup(c,255);
if (c != NULL)
free(c);
return rc;
}
int PerlCallbackGetSecret( void *context, const char *mechanism, const char *auth_identity,
const char *realm, sasl_secret_t ** secret)
{
struct _perlcontext *cp = (struct _perlcontext *) context;
int rc = SASL_OK;
STRLEN len;
AV *args;
char *c = NULL;
args = newAV();
av_push(args, newSVpv(realm,0));
av_push(args, newSVpv(auth_identity,0));
av_push(args, newSVpv(mechanism,0));
rc = PerlCallbackSub(cp,&c,&len,args);
av_clear(args);
av_undef(args);
_DEBUG("GetSecret, %s ,%s ,%s",mechanism,auth_identity,realm);
if (rc == SASL_OK && c != NULL)
rc = FillSecret_t(c,len,secret);
else
rc = SASL_FAIL;
_DEBUG("GetSecret, pass: %s, rc: %x",(*secret)->data,rc);
if (c != NULL)
free(c);
return rc;
}
#endif
=pod
=head1 CALLBACKS
Callbacks are very important. It depends on the mechanism which callbacks
have to be set. It is not a failure to set callbacks even they aren't used.
(e.g. password-callback when using GSSAPI or KERBEROS_V4)
The Cyrus-SASL library uses callbacks when the application
needs some information. Common reasons are getting
usernames and passwords.
Authen::SASL::XS allows Cyrus-SASL to use perl-variables and perl-subs
as callback-targets.
Currently Authen::SASL::XS supports the following Callback types:
(for a more detailed description on what the callback type is used for
see the respective man pages)
B<Remark>: All callbacks, which have to return some values (e.g.: **result in
C<sasl_getsimple_t>) do this by returning the value(s). See example below.
=over 4
=item user (client)
=item auth (client)
=item language (client)
This callbacks represent the C<sasl_getsimple_t> from the library.
Input: none
Output: C<username>, C<authname> or C<language>
=item password (client)
=item pass (client)
This callbacks represent the C<sasl_getsecret_t> from the library.
Input: none
Output: C<password>
=item realm <client>
This callback represents the C<sasl_getrealm_t> from the library.
Input: a list of available realms
Output: the chosen realm
(This has nothing to do with GSSAPI or KERBEROS_V4 realm).
=item checkpass (server, SASL v2 only)
This callback represents the C<sasl_server_userdb_checkpass_t> from the
library.
Input: C<username>, C<password>
Output: true or false
=item getsecret (server, SASL v1 only)
This callback represents the C<sasl_server_getsecret_t> from the library. Sasl
will check if the passwords are matching.
Input: C<mechanism>, C<username>, C<default_realm>
Output: C<secret_phrase (password)>
B<Remark>: Programmers that are using should specify both callbacks (getsecret and checkpass).
Then, depending on you Cyrus SASL library either the one or the other is called. Cyrus SASL v1
ignores checkpass and Cyrus SASL v2 ignores getsecret.
=item putsecret (SASL v1) and setpass (SASL v2)
are currently not supported (and won't be, unless someone needs it).
=item canonuser (server/client in SASL v2, server only in SASL v1)
This callback name represents the C<sasl_canon_user_t> from the library.
Input: C<Type of principal>, C<principal>, C<userrealm> and maximal allowed length of the output.
Output: canonicalised C<principal>
C<Type of principal> is "AUTHID" for Authentication ID or "AUTHZID"
for Authorisation ID.
B<Remark>: This callback is ideal to get the username of the user using your service.
If C<Authen::SASL::XS> is linked to Cyrus SASL v1, which doesn't have a canonuser callback,
it will simulate this callback by using the authorize callback internally. Don't worry, the
authorize callback is available anyway.
=item authorize (server)
This callback represents the C<sasl_authorize_t> from the library.
Input: C<authenticated_username>, C<requested_username>, (C<default_realm> SASL v2 only)
Output: C<canonicalised_username> SASL v1 resp. true or false when using SASL v2 lib
There is something TODO, I think.
=item setpass (server, SASL v2 only)
This callback represents the C<sasl_server_userdb_setpass_t> from the library.
Input: C<username>, C<new_password>, C<flags> (0x01 CREATE, 0x02 DISABLE,
0x04 NOPLAIN)
Out: true or false
=back
=head2 Ways to pass a callback
Authen::SASL::XS supports three different ways to pass a callback
=over 4
=item CODEREF
If the value passed is a code reference then, when needed, it will be called.
=item ARRAYREF
If the value passed is an array reference, the first element in the array
must be a code reference. When the callback is called the code reference
will be called with the value from the array passed after.
=item SCALAR
All other values passed will be returned directly to the SASL library
as the answer to the callback.
=back
=head2 Example of setting callbacks
$sasl = new Authen::SASL (
mechanism => "PLAIN",
callback => {
# Scalar
user => "mannfred",
pass => $password,
language => 1,
# Coderef
auth => sub { return "klaus", }
realm => \&getrealm,
# Arrayref
canonuser => [ \&canon, $self ],
}
);
The last example is ideal for using object methods as callback functions.
Then you can do something like this:
sub canon
{
my ($this,$type,$realm,$maxlen,$user) = @_;
$this->{_username} = $user if ($type eq "AUTHID");
return $user;
}
=cut
/* Convert a Perl callback name into a C callback ID */
static
int CallbackNumber(char *name)
{
if (!strcasecmp(name, "user")) return(SASL_CB_USER);
else if (!strcasecmp(name, "username")) return(SASL_CB_USER);
else if (!strcasecmp(name, "auth")) return(SASL_CB_AUTHNAME);
else if (!strcasecmp(name, "authname")) 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);
else if (!strcasecmp(name, "realm")) return(SASL_CB_GETREALM);
else if (!strcasecmp(name, "authorize")) return(SASL_CB_PROXY_POLICY);
else if (!strcasecmp(name, "canonuser")) return(SASL_CB_CANON_USER);
else if (!strcasecmp(name, "checkpass")) return(SASL_CB_SERVER_USERDB_CHECKPASS);
else if (!strcasecmp(name, "setpass")) return(SASL_CB_SERVER_USERDB_SETPASS);
else if (!strcasecmp(name, "getsecret")) return(SASL_CB_SERVER_GETSECRET);
else if (!strcasecmp(name, "putsecret")) return(SASL_CB_SERVER_PUTSECRET);
#ifdef SASL2
croak("Unknown callback: '%s'. (user|auth|language|pass|realm|checkpass|canonuser|authorize)\n", name);
#else
croak("Unknown callback: '%s'. (user|auth|language|pass|realm|getsecret|canonuser|authorize)\n", name);
#endif
}
/*
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(SV *action, struct _perlcontext *pcb, sasl_callback_t *cb)
{
__DEBUG("AddCallback");
if (SvROK(action)) { /* user => <ref> */
__DEBUG("SvROK -> Dereferencing");
action = SvRV(action);
}
pcb->func = NULL;
pcb->intparam = 0;
pcb->param = NULL;
_DEBUG("action type: %d",SvTYPE(action));
switch (SvTYPE(action)) {
case SVt_PVCV: /* user => sub { }, user => \&func */
pcb->func = action;
__DEBUG("SVt_PVCV");
break;
case SVt_PVAV: /* user => [ \&func, $param ] */
pcb->func = av_shift((AV *)action); pcb->param = av_shift((AV *)action);
_DEBUG("Parametered Callback: %s",SvPV_nolen(pcb->param));
break;
case SVt_PV: /* user => $param */
case SVt_PVMG: /* user => $self->{value} */
case SVt_PVIV: /* $self->{value} = ""; [...] user => $self->{value} */
pcb->param = action;
_DEBUG("SVt- PV PVMG PVIV (%s)",SvPV_nolen(pcb->param));
break;
case SVt_IV: /* user => 1 */
pcb->intparam = SvIV(action);
__DEBUG("SVt_IV");
break;
default:
_DEBUG("Unknown parameter %d %s",SvTYPE(action),SvPV_nolen(action));
croak("Unknown parameter to %lx callback.\n", cb->id);
break;
}
_DEBUG("Callback: %lx",cb->id);
/* Write the C SASL callbacks */
switch (cb->id)
{
case SASL_CB_USER:
case SASL_CB_AUTHNAME:
case SASL_CB_LANGUAGE:
cb->proc = (int (*)(void)) PerlCallback;
break;
case SASL_CB_PASS:
cb->proc = (int (*)(void)) PerlCallbackSecret;
break;
case SASL_CB_GETREALM:
cb->proc = (int (*)(void)) PerlCallbackRealm;
break;
case SASL_CB_ECHOPROMPT:
case SASL_CB_NOECHOPROMPT:
break;
case SASL_CB_PROXY_POLICY:
cb->proc = (int (*)(void)) PerlCallbackAuthorize;
break;
case SASL_CB_CANON_USER:
cb->proc = (int (*)(void)) PerlCallbackCanonUser;
break;
#ifdef SASL2
case SASL_CB_SERVER_USERDB_CHECKPASS:
cb->proc = (int (*)(void)) PerlCallbackServerCheckPass;
break;
case SASL_CB_SERVER_USERDB_SETPASS:
cb->proc = (int (*)(void)) PerlCallbackServerSetPass;
break;
#else
// SASL 1 Servercallbacks:
case SASL_CB_SERVER_GETSECRET:
cb->proc = (int (*)(void)) PerlCallbackGetSecret;
break;
case SASL_CB_SERVER_PUTSECRET:
// Not implemented yet maybe TODO, if ever needed
break;
#endif
default:
break;
}
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, Authen_SASL_XS sasl)
{
char *key;
int count=0,i;
int32_t l;
#ifndef SASL2
// Missing SASL1 canonuser workaround
int canon=-1,auth=-1;
#endif
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
* Only valid (non-zero) callbacks are counted.
*/
hv_iterinit(hash);
for (iter=hv_iternext(hash); iter; iter=hv_iternext(hash))
{
key = hv_iterkey(iter,&l);
if ((i=CallbackNumber(key))) {
#ifndef SASL2
// Missing SASL1 canonuser workaround
if (i == SASL_CB_CANON_USER) canon = count;
if (i == SASL_CB_PROXY_POLICY) auth = count;
#endif
count++;
}
}
_DEBUG("Found %d valid callback(s)",count);
/* Allocate space for the callbacks */
if (sasl->callbacks) {
free(sasl->callbacks->context);
free(sasl->callbacks);
}
pcb = (struct _perlcontext *) malloc(count * sizeof(struct _perlcontext));
if (pcb == NULL)
croak("Out of memory\n");
l = (count + 1) * sizeof(sasl_callback_t);
sasl->callbacks = (sasl_callback_t *)malloc(l);
if (sasl->callbacks == NULL)
croak("Out of memory\n");
memset(sasl->callbacks, 0, l);
/* Run through all of parent's callback types, fill in the sasl->callbacks
* Only valid (non-zero) callbacks will be filled in
*/
hv_iterinit(hash);
count = 0;
for (iter=hv_iternext(hash); iter; iter=hv_iternext(hash)) {
key = hv_iterkey(iter,&l);
_DEBUG("Callback %d, %s",count, key);
if ( (i = CallbackNumber(key))) {
_DEBUG("Adding Callback %s %d %x.",key,count,i);
sasl->callbacks[count].id = i;
val = hv_iterval(hash, iter);
AddCallback(val, &pcb[count], &sasl->callbacks[count]);
count++;
}
else
_DEBUG("Ignore Callback %s %d %x.",key,count,i);
}
sasl->callbacks[count].id = SASL_CB_LIST_END;
sasl->callbacks[count].context = pcb;
sasl->callback_count = count;
#ifndef SASL2
// Missing-SASL1-canonuser workaround
// If canon is needed
if (canon != -1)
{
if (auth != -1) // and auth also
sp_canon = sasl->callbacks[canon].context; // Auth has to call canon
else
{
sasl->callbacks[canon].id = SASL_CB_PROXY_POLICY; // call canon when auth is actually needed
sasl->callbacks[canon].proc = PerlCallbackCanonUser1;
}
}
_DEBUG("index for auth: %d, index for canon: %d",auth,canon);
#endif
return;
}
#ifdef SASL2
#define SASL_IP_LOCAL 5
#define SASL_IP_REMOTE 6
#endif
static
int PropertyNumber(char *name)
{
if (!strcasecmp(name, "user")) return SASL_USERNAME;
else if (!strcasecmp(name, "ssf")) return SASL_SSF;
else if (!strcasecmp(name, "maxout")) return SASL_MAXOUTBUF;
else if (!strcasecmp(name, "optctx")) return SASL_GETOPTCTX;
#ifdef SASL2
else if (!strcasecmp(name, "realm")) return SASL_DEFUSERREALM;
else if (!strcasecmp(name, "iplocalport")) return SASL_IPLOCALPORT;
else if (!strcasecmp(name, "ipremoteport")) return SASL_IPREMOTEPORT;
else if (!strcasecmp(name, "service")) return SASL_SERVICE;
else if (!strcasecmp(name, "serverfqdn")) return SASL_SERVERFQDN;
else if (!strcasecmp(name, "authsource")) return SASL_AUTHSOURCE;
else if (!strcasecmp(name, "mechname")) return SASL_MECHNAME;
else if (!strcasecmp(name, "authuser")) return SASL_AUTHUSER;
else if (!strcasecmp(name, "sockname")) return SASL_IP_LOCAL;
else if (!strcasecmp(name, "peername")) return SASL_IP_REMOTE;
#else
else if (!strcasecmp(name, "realm")) return SASL_REALM;
else if (!strcasecmp(name, "iplocal")) return SASL_IP_LOCAL;
else if (!strcasecmp(name, "sockname")) return SASL_IP_LOCAL;
else if (!strcasecmp(name, "ipremote")) return SASL_IP_REMOTE;
else if (!strcasecmp(name, "peername")) return SASL_IP_REMOTE;
#endif
#ifdef SASL2
croak("Unknown SASL property: '%s' (user|ssf|maxout|realm|optctx|iplocalport|ipremoteport|service|serverfqdn|authsource|mechname|authuser)\n", name);
#else
croak("Unknown SASL property: '%s' (user|ssf|maxout|realm|optctx|sockname|peername)\n", name);
#endif
return -1;
}
int init_sasl (SV* parent,char* service,char* host, Authen_SASL_XS *sasl,int client)
{
HV *hash;
SV **hashval;
if (sasl == NULL)
return SASL_FAIL;
// TODO if struct is already in use and now another type
if (*sasl != NULL && (*sasl)->is_client != client)
return SASL_FAIL;
}
#ifdef SASL2
void set_secprop (Authen_SASL_XS sasl)
{
sasl_security_properties_t ssp;
if (sasl == NULL)
return;
memset(&ssp, 0, sizeof(ssp));
ssp.maxbufsize = 0xFFFF;
ssp.max_ssf = 0xFF;
sasl_setprop(sasl->conn, SASL_SEC_PROPS, &ssp);
}
#endif
MODULE=Authen::SASL::XS PACKAGE=Authen::SASL::XS
=head1 Authen::SASL::XS METHODS
=over 4
=item server_new ( SERVICE , HOST = "" , IPLOCALPORT , IPREMOTEPORT )
Constructor for creating server-side sasl contexts.
Creates and returns a new connection object blessed into Authen::SASL::XS.
It is on that returned reference that the following methods are available.
The SERVICE is the name of the service being implemented, which may be used
by the underlying mechanism. An example service therefore is "ldap".
=cut
Authen_SASL_XS
server_new(pkg, parent, service, host = NULL, iplocalport=NULL, ipremoteport=NULL, ...)
char *pkg
SV *parent
char *service
char *host
char *iplocalport
char *ipremoteport
CODE:
{
/* TODO realm parameter */
Authen_SASL_XS sasl = NULL;
int rc;
if ((rc = init_sasl(parent,service,host,&sasl,SASL_IS_SERVER)) != SASL_OK)
croak("Saslinit failed. (%x)\n",rc);
_DEBUG("server_new: Service: %s Server: %s, %s %s %s %s",sasl->service,sasl->server,service,host,iplocalport,ipremoteport);
if ((rc = sasl_server_init(NULL,sasl->service)) != SASL_OK)
SetSaslError(sasl,rc,"server_init error.");
#ifdef SASL2
rc = sasl_server_new(sasl->service, sasl->server, NULL, iplocalport, ipremoteport, sasl->callbacks, 1, &sasl->conn);
#else
rc = sasl_server_new(sasl->service, sasl->server, NULL, sasl->callbacks, 1, &sasl->conn);
#endif
if (SetSaslError(sasl,rc,"server_new error.") == SASL_OK)
{
#ifdef SASL2
set_secprop(sasl);
#endif
}
RETVAL = sasl;
}
OUTPUT:
RETVAL
=pod
=item client_new ( SERVICE , HOST , IPLOCALPORT , IPREMOTEPORT )
Constructor for creating server-side sasl contexts.
Creates and returns a new connection object blessed into Authen::SASL::XS.
It is on that returned reference that the following methods are available.
The SERVICE is the name of the service being implemented, which may be used
by the underlying mechanism. An example service is "ldap". The HOST is the
name of the server being contacted, which may also be used
by the underlying mechanism.
=back
B<Remark>:
This and the C<server_new> function are called by L<Authen::SASL> when using
its C<*_new> function. Since the user has to use Authen::SASL anyway, normally
it is not necessary to call this function directly.
IPLOCALPORT and IPREMOTEPORT arguments are only available, when ASC is
linked against Cyrus SASL 2.x. This arguments are needed for KERBEROS_V4
and CS 2.x on the server side. Don't know if it necessary for the client
side. Format of this arguments in an IPv4 environment should be: a.b.c.d;port.
See sasl_server_new(3) for details.
=over 4
=item
See SYNOPSIS for an example.
=cut
Authen_SASL_XS
client_new(pkg, parent, service, host, iplocalport = NULL, ipremoteport = NULL, ...)
char *pkg
SV *parent
char *service
char *host
char *iplocalport
char *ipremoteport
CODE:
{
Authen_SASL_XS sasl = NULL;
int rc;
if ((rc = init_sasl(parent,service,host,&sasl,SASL_IS_CLIENT)) != SASL_OK)
croak("Saslinit failed. (%x)\n",rc);
sasl_client_init(NULL);
_DEBUG("service: %s, host: %s, mech: %s",sasl->service,sasl->server,sasl->mech);
#ifdef SASL2
rc = sasl_client_new(sasl->service, sasl->server, iplocalport, ipremoteport, sasl->callbacks, 1, &sasl->conn);
#else
rc = sasl_client_new(sasl->service, sasl->server, sasl->callbacks, 1, &sasl->conn);
#endif
if (SetSaslError(sasl,rc,"client_new error.") == SASL_OK)
{
#ifdef SASL2
set_secprop(sasl);
#endif
}
RETVAL = sasl;
}
OUTPUT:
RETVAL
=pod
=item server_start ( CHALLENGE )
C<server_start> begins the authentication using the chosen mechanism.
If the mechanism is not supported by the installed Cyrus-SASL it fails.
Because for some mechanisms the client has to start the negotiation,
you can give the client challenge as a parameter.
=cut
char *
server_start(sasl,instring=NULL)
Authen_SASL_XS sasl;
const char *instring;
PREINIT:
int rc;
unsigned outlen;
STRLEN inlen;
#ifdef SASL2
const char *outstring = NULL;
#else
char *outstring = NULL;
const char *error =NULL;
#endif
PPCODE:
_DEBUG("serverstart mech: %s",sasl->mech);
if (sasl->error_code)
XSRETURN_UNDEF;
if (instring != NULL)
SvPV(ST(1),inlen);
else
inlen = 0;
_DEBUG("serverstart len: %d",inlen);
_DEBUG("Server step: %s %d", instring,inlen);
#ifdef SASL2
rc = sasl_server_start(sasl->conn,sasl->mech, instring, inlen, &outstring, &outlen);
#else
rc = sasl_server_start(sasl->conn,sasl->mech, instring, inlen, &outstring, &outlen, &error);
#endif
SetSaslError(sasl,rc,"server_start error."); // SASL_CONTINUE has to be set
{
#ifdef SASL2
const char *outstring=NULL;
#else
char *outstring=NULL;
#endif
int rc;
unsigned int outlen=0;
STRLEN inlen;
if (sasl->error_code)
XSRETURN_UNDEF;
instring = SvPV(ST(1),inlen);
rc = sasl_encode(sasl->conn, instring, inlen, &outstring, &outlen);
if (SetSaslError(sasl,rc,"sasl_encode failed") != SASL_OK)
XSRETURN_UNDEF;
else
XPUSHp(outstring, outlen);
}
char *
decode(sasl, instring)
Authen_SASL_XS sasl
char *instring
PPCODE:
{
#ifdef SASL2
const char *outstring=NULL;
#else
char *outstring=NULL;
#endif
int rc;
unsigned int outlen=0;
STRLEN inlen;
if (sasl->error_code)
XSRETURN_UNDEF;
instring = SvPV(ST(1),inlen);
rc = sasl_decode(sasl->conn, instring, inlen, &outstring, &outlen);
if (SetSaslError(sasl,rc,"sasl_decode failed.") != SASL_OK)
XSRETURN_UNDEF;
else
XPUSHp(outstring, outlen);
}
int
callback(sasl, ...)
Authen_SASL_XS sasl
CODE:
/*
This function is unnecessary since there is no
chance for changing callbacks in sasl after (server|
client)_new function calls. But without calling one
of these functions (from perl) you do not have an
object of this class. So you cannot call ->callback.
At least I was not able to use this function to fill in
a callback with this function.
-Patrick
*/
croak("Deprecated. Don't use, it isn't working anymore.");
RETVAL = 0;
OUTPUT:
RETVAL
=pod
=item error ( )
C<error> returns an array with all known error messages.
Basicly the sasl_errstring function is called with the current error_code.
When using Cyrus-SASL 2.x library also the string returned by sasl_errdetail
is given back. Additionally the special Authen::SASL::XS advise is
returned if set.
After calling the C<error> function, the error code and the special advice
are thrown away.
=cut
char *
error(sasl)
Authen_SASL_XS sasl
PPCODE:
{
_DEBUG("Current Error %x",sasl->error_code);
XPUSHs(newSVpv((char *)sasl_errstring(sasl->error_code,NULL,NULL),0));
#ifdef SASL2
XPUSHs(newSVpv((char *)sasl_errdetail(sasl->conn),0));
#endif
if (sasl->additional_errormsg != NULL)
XPUSHs(newSVpv(sasl->additional_errormsg,0));
// only real error should be overwritten
if (sasl->error_code != SASL_OK && sasl->error_code != SASL_CONTINUE)
{
sasl->error_code = SASL_OK;
if (sasl->additional_errormsg != NULL)
free(sasl->additional_errormsg);
sasl->additional_errormsg = NULL;
}
__DEBUG("End of Error");
}
=pod
=item code ( )
C<code> returns the current Cyrus-SASL error code.
=cut
#ifdef SASL2
case SASL_IPLOCALPORT:
case SASL_IPREMOTEPORT:
XPUSHp( (char *)value, strlen((char *)value));
break;
case SASL_IP_LOCAL:
propnum = SASL_IPLOCALPORT;
{
char *addr = inet_ntoa( (*(struct in_addr *)value));
XPUSHp( addr, strlen(addr));
}
break;
case SASL_IP_REMOTE:
propnum = SASL_IPREMOTEPORT;
{
char *addr = inet_ntoa( (*(struct in_addr *)value));
XPUSHp( addr, strlen(addr));
}
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_nolen( ST(x+1) );
if (SvTYPE(prop) == SVt_IV) {
propnum = SvIV(prop);
} else if (SvTYPE(prop) == SVt_PV) {
name = SvPV_nolen(prop);
propnum = PropertyNumber(name);
}
#ifdef SASL2
if ((propnum == SASL_IP_LOCAL) || (propnum == SASL_IP_REMOTE))
rc = 0;
else
#endif
rc = sasl_setprop(sasl->conn, propnum, value);
if (SetSaslError(sasl,rc,"sasl_setprop failed.") != SASL_OK)
RETVAL = 1;
}
}
void
DESTROY(sasl)
Authen_SASL_XS sasl
CODE:
{
__DEBUG("DESTROY");
if (sasl->conn) sasl_dispose(&sasl->conn);
if (sasl->callbacks) {
free(sasl->callbacks[sasl->callback_count].context);
free(sasl->callbacks);
}
if (sasl->service) free(sasl->service);
if (sasl->mech) free(sasl->mech);
if (sasl->additional_errormsg) free(sasl->additional_errormsg);
free(sasl);
sasl_done();
}
=pod
=back
=head1 EXAMPLE
=head2 Server-side
# The example uses Cyrus-SASL v2
# Set the SASL_PATH to the location of the SASL-Plugins
# default is /usr/lib/sasl2
$ENV{'SASL_PATH'} = "/opt/products/sasl/2.1.15/lib/sasl2";
#
my $sasl = Authen::SASL->new (
mechanism => "PLAIN",
callback => {
checkpass => \&checkpass,
canonuser => \&canonuser,
}
);
# Creating the Authen::SASL::XS object
my $conn = $sasl->server_new("service","","ip;port local","ip;port remote");
# Clients first string (maybe "", depends on mechanism)
# Client has to start always
sendreply( $conn->server_start( &getreply() ) );
while ($conn->need_step) {
sendreply( $conn->server_step( &getreply() ) );
}
if ($conn->code == 0) {
print "Negotiation succeeded.\n";
} else {
print "Negotiation failed.\n";
}
=head2 Client-side
# The example uses Cyrus-SASL v2
# Set the SASL_PATH to the location of the SASL-Plugins
# default is /usr/lib/sasl2
$ENV{'SASL_PATH'} = "/opt/products/sasl/2.1.15/lib/sasl2";
#
my $sasl = Authen::SASL->new (
mechanism => "PLAIN",
callback => {
( run in 1.719 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )