view release on metacpan or  search on metacpan

XS.xs  view on Meta::CPAN

    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

		_DEBUG("Server step out: %s %d",outstring, outlen);
		if (rc != SASL_OK && rc != SASL_CONTINUE)
			XSRETURN_UNDEF;
		else // Everything works fine
			XPUSHp(outstring, outlen);

=pod

=item client_start ( )

The initial step to be performed. Returns the initial value to pass to the server.
Client has to start the negotiation always.

=cut

char *
client_start(sasl)
    Authen_SASL_XS sasl
  PREINIT:
	int rc;
	unsigned outlen;
#ifdef SASL2
	const char *outstring;
#else
	char *outstring;
#endif

	const char *mech;
  PPCODE:
		if (sasl->error_code != SASL_OK)
			XSRETURN_UNDEF;

      _DEBUG("mech: %s",sasl->mech);
#ifdef SASL2
      rc = sasl_client_start(sasl->conn, sasl->mech, NULL, &outstring, &outlen, &mech);
#else
      rc = sasl_client_start(sasl->conn, sasl->mech, NULL, NULL, &outstring, &outlen, &mech);
#endif
	  _DEBUG("client_start. error %x, len: %d",rc,outlen);
	  SetSaslError(sasl,rc,"client_start error. (Callbacks?)");
      if (rc != SASL_OK && rc != SASL_CONTINUE)
		XSRETURN_UNDEF;
	  else
	    XPUSHp(outstring, outlen);

=pod

=item server_step ( CHALLENGE )

C<server_step> performs the next step in the negotiation process. The
first parameter you give is the clients challenge/response.

=cut


char *
server_step(sasl, instring)
	Authen_SASL_XS sasl
	char *instring
	PREINIT:
#ifdef SASL2
		const char *outstring=NULL;
#else
		char *outstring=NULL;
		const char *error=NULL;
#endif
		int rc;
		unsigned int outlen=0;
                STRLEN inlen;
	PPCODE:
		if (sasl->error_code != SASL_CONTINUE)
			XSRETURN_UNDEF;

		SvPV(ST(1),inlen);
		_DEBUG("Server step: %s %d", instring,inlen);
#ifdef SASL2
		rc = sasl_server_step(sasl->conn,instring,inlen,&outstring,&outlen);
#else
		rc = sasl_server_step(sasl->conn,instring,inlen,&outstring,&outlen,NULL);
#endif
		// Setting error, if any
		SetSaslError(sasl,rc,"server_step error.");
		// return undef if error, code() will give the truth
		if (rc != SASL_OK && rc != SASL_CONTINUE)
			XSRETURN_UNDEF;
		else
			XPUSHp(outstring, outlen);

=pod

=item client_step ( CHALLENGE )

=back

B<Remark>:
C<client_start>, C<client_step>, C<server_start> and C<server_step>
will return the respective sasl response or undef. The returned value
says nothing about the current negotiation status. It is absolutely possible
that one of these functions return undef and everything is fine for SASL,
there is only another step needed.

Therefore you have to check C<need_step> and C<code> during negotiation.

See example below.

=over 4

=item

=cut


char *
client_step(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 != SASL_CONTINUE)
      XSRETURN_UNDEF;

    SvPV(ST(1),inlen);

	_DEBUG("client_step: inlen: %d",inlen);

    rc = sasl_client_step(sasl->conn, instring, inlen, NULL, &outstring, &outlen);

	SetSaslError(sasl,rc,"client_step.");

	_DEBUG("client_step: error code: %x, len: %d",rc,outlen);
	if (rc != SASL_OK && rc != SASL_CONTINUE)
		XSRETURN_UNDEF;
	else
		XPUSHp(outstring, outlen);
  }

=pod

=item listmech( START , SEPARATOR , END )

C<listmech> returns a string containing all mechanisms allowed for the user
set by C<user>. START is the token which will be put at the beginning of the
string, SEPARATOR is the token which will be used to separate the mechanisms
and END is the token which will be put at the end of returned string.

=cut

char *
listmech(sasl,start="",separator="|",end="")
	Authen_SASL_XS sasl;
	const char* start;
	const char* separator;
	const char* end;
 	PPCODE:
	{
	    int rc;
#ifdef SASL2
	    const char *mechs;
#else
		char *mechs;
#endif
		int mechcount;
	    unsigned mechlen;

		rc = sasl_listmech(sasl->conn,sasl->user,start,separator,end,&mechs,&mechlen,&mechcount);

		if (rc == SASL_OK)
			XPUSHp(mechs,mechlen);
		else
		{
			SetSaslError(sasl,rc,"listmech error.");
			XSRETURN_UNDEF;
		}
	}


#ifdef SASL2

=pod

=item setpass(user, newpassword, oldpassword, flags)

=item checkpass(user, password)

C<setpass> and C<checkpass> is only available when using Cyrus-SASL 2.x library.

C<setpass> sets a new password (depends on the mechanism if the setpass callback
is called). C<checkpass> checks a password for the user (calls the checkpass
callback).

For both function see the man pages of the Cyrus SASL for a detailed description.

Both functions return true on success, false otherwise.

=cut

int
setpass(sasl, user, pass, oldpass, flags=0)
	Authen_SASL_XS sasl;
	const char *user;
	const char *pass;
	const char *oldpass;
	int flags;
PREINIT:
		int rc;
PPCODE:
		_DEBUG("setpass: %s,%s,%s,%d",user,pass,oldpass,flags);
		rc = sasl_setpass (sasl->conn,user,
						pass,strlen(pass),
						oldpass,strlen(oldpass),
						flags);
		XPUSHi(rc);


int checkpass(sasl,user,pass)
	Authen_SASL_XS sasl;
	const char *user;
	const char *pass;
PREINIT:
	int rc;
PPCODE:
	_DEBUG("checkpass: %s,%s",user,pass);
	rc = sasl_checkpass (sasl->conn,
			user, strlen(user),
			pass, strlen(pass));
	XPUSHi(rc);

=pod

=item global_listmech ( )

C<global_listmech> is only available when using Cyrus-SASL 2.x library.

It returns an array with all mechanisms loaded by the library.

=cut


void
global_listmech(sasl)
	Authen_SASL_XS sasl
	PREINIT:
		int i;
		const char **mechs;
	PPCODE:
		if (sasl->error_code)
			XSRETURN_UNDEF;
		mechs = sasl_global_listmech();
		if (mechs)
			for (i = 0; mechs[i]; i++)
				XPUSHs(sv_2mortal(newSVpv(mechs[i],0)));
		else
			XSRETURN_UNDEF;

#endif

=pod

=item encode ( STRING )

=item decode ( STRING )

Cyrus-SASL developers suggest using the C<encode> and C<decode> functions
for every traffic which will run over the network after a successful authentication

C<encode> returns the encrypted string generated from STRING.
C<decode> returns the decrypted string generated from STRING.

It depends on the used mechanism how secure the encryption will be.

=cut

char *
encode(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_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

int
code(sasl)
    Authen_SASL_XS sasl
  CODE:
    RETVAL=sasl->error_code;
  OUTPUT:
    RETVAL


=pod

=item mechanism ( )

C<mechanism> returns the current used authentication mechanism.

=cut

char *
mechanism(sasl)
    Authen_SASL_XS sasl
  CODE:
    RETVAL = sasl->mech;
  OUTPUT:
    RETVAL



char *
host(sasl, ...)
    Authen_SASL_XS sasl
  CODE:
    if (items > 1) {
      if (sasl->server) free(sasl->server);
      sasl->server = strdup(SvPV_nolen(ST(1)));
    }
    RETVAL = sasl->server;
  OUTPUT:
    RETVAL



char *
user(sasl, ...)
    Authen_SASL_XS sasl
  CODE:
    if (items > 1) {
      if (sasl->user) free(sasl->user);
      sasl->user = strdup(SvPV_nolen(ST(1)));
    }
    RETVAL = sasl->user;
  OUTPUT:
    RETVAL



char *
service(sasl, ...)
    Authen_SASL_XS sasl
  CODE:
    if (items > 1) {
      if (sasl->service) free(sasl->service);
      sasl->service = strdup(SvPV_nolen(ST(1)));
    }
    RETVAL = sasl->service;
  OUTPUT:
    RETVAL


=pod

=item need_step ( )

C<need_step> returns true if another step is need by the SASL library. Otherwise
false is returned. You can also use C<code == 1> but it looks smarter I think.
That's why we all using perl, eh?

=cut

int
need_step(sasl)
	Authen_SASL_XS sasl;
	CODE:
		RETVAL = sasl->error_code == SASL_CONTINUE;
	OUTPUT:
		RETVAL


int
property(sasl, ...)
Authen_SASL_XS sasl
PPCODE:
{
#ifdef SASL2
	const void *value=NULL;
#else
	void *value=NULL;
#endif
	char *name;
	int rc, x, propnum=-1;
	SV *prop;

	RETVAL = SASL_OK;

	if (!sasl->conn) {
#ifdef SASL2
		SetSaslError(sasl,SASL_NOTINIT,"property failed, init missed.");
		RETVAL = SASL_NOTINIT;
#else
		SetSaslError(sasl,SASL_FAIL,"property failed, init missed.");
		RETVAL = SASL_FAIL;
#endif
		items = 0;
	}
/* Querying the value of a property */
	if (items == 2) {
		name = SvPV_nolen(ST(1));
		propnum = PropertyNumber(name);
		rc = sasl_getprop(sasl->conn, propnum, &value);

		if (value == NULL || rc != SASL_OK)
			XSRETURN_UNDEF;

		switch(propnum){
			case SASL_USERNAME:
#ifdef SASL2
			case SASL_DEFUSERREALM:
#else
			case SASL_REALM:
#endif
				XPUSHp( (char *)value, strlen((char *)value));
			break;
			case SASL_SSF:
			case SASL_MAXOUTBUF:
				XPUSHi((long int)value);
			break;
#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));