Authen-SASL-Cyrus-0.13-server/0040755002635700003130000000000010260737467016154 5ustar pboettchsysprogAuthen-SASL-Cyrus-0.13-server/CHANGES0100555002635700003130000000725610260737154017150 0ustar pboettchsysprogHistory of updates to Authen::SASL::Cyrus 0.13-server Russ Allbery: the 0.12-server distribution of this module has a typemap that ends up casting the pointer return from server_new and client_new through an int. This looks like it's causing pointer truncation and various problems on some 64-bit platforms (particularly Debian alpha and Debian ia64). There is a simpler fix than the patch below (just replacing int with long will work on most platforms, probably), but reading through the perlxs man page, there's apparently a specific way in which one is supposed to handle module data T_PTROBJ_SPECIAL. I went ahead and implemented that, which also improves error reporting a bit. After applying the following patch, the resulting C code no longer casts through an int (it casts through an IV instead, but that's sufficient on all Unix platforms at least). typedef for struct authensasl to Authen_SASL_Cyrus. 0.12-server merged some of the changes from Authen::SASL::Cyrus 0.12 changed version named in order to distinguish from the Authen::SASL::Cyrus by Mark Adamson. 0.11 added setpass and checkpass methods added setpass callback applied a patch by Graham Barr (found with google) for enabling GSSAPI authentication (fix a problem in Security.pm) added a check for undef return values when using sub-callbacks (Thanks to Quanah Gibson-Mount for discovering this one) 0.10 Added the iplocalport and ipremote port to *_new methods, after filling in the appropriate string (see doc) ASC is able to manage KERBEROS_V4 on the server side solved bug in property handling (strlen(NULL) after received NULL as data from a sasl_getprop) 0.09 Added callback documenation Perl-Callback types (PVMG, PV, PVIV) handling extended 0.08-desy-internal Almost complete rewrite of Perlcallbacks from Cyrus.xs. SASL-Server functionality added, so servers written in Perl can use SASL as Authentication Layer. Synchronize callbacks between Cyrus SASL v1 and v2. Many changes in the internal handling of sasl variables. Documentation inside the XS-file, do motivate myself to write docs 0.07 Memcpy fix provided by Maurice Massar 0.06 Added SASL V2 support patch provided by Leif Johansson. 0.05 Added the SASL_CB_PASS callback. This callback, unfortunately, does not put the caller's "context" as the first parameter to the callback function. This means that the PerlCallback() function has to be able to determine if the _perlcontext is the first parameter or the second. Added a magic number as the first field of the _perlcontext struct to help PerlCallback() decide which parameter is the perl context. 0.04 Added a method "securesocket" that takes a file handle and returns a new file handle that is tied to the Security subclass added in 0.03. In this way, a client program can take the object returned from client_new() and call the securesocket() method on it, passing in the client's file handle, without ever having to know about the Security subclass. Also added a "tiehandle" method which will take the same file handle as "securesocket", and tie it directly to the Security subclass. The difference being "securesocket" returns a new file handle, and "tiehandle" ties the handle passed in. 0.03 Added encryption layer. Cyrus.xs now has encode() and decode() methods. Added a "Security" subclass that can be used to tie a filehandle to perform encryption on write() and decryption on read(). The new() method ties a passed in glob to the class. 0.02 Encryption layer not ready yet, so changed the "secflag" param in the call to sasl_client_new() from 1 to 0. Otherwise, the server will start expecting encrypted requests and sending encrypted responses after the authentication, and the client cannot encrypt/decrypt. 0.01 Initial release Authen-SASL-Cyrus-0.13-server/META.yml0100444002635700003130000000064710260737466017426 0ustar pboettchsysprog# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Authen-SASL-Cyrus version: 0.13-server version_from: Cyrus.pm installdirs: site requires: Authen::SASL: 2.08 Test::More: 0 Test::Simple: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Authen-SASL-Cyrus-0.13-server/Cyrus.xs0100555002635700003130000014003710260737435017633 0ustar pboettchsysprog=head1 NAME Authen::SASL::Cyrus - 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(, , , ); my $conn = $sasl->server_new(, , , ); =head1 DESCRIPTION SASL is a generic mechanism for authentication used by several network protocols. B 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 and C methods. You have to use the C new-constructor to create a SASL object. The C object then holds all necessary variables and callbacks, which you gave when creating the object. C and C will retrieve needed information from this object. =cut #include #include #include #ifdef SASL2 #include #else #include #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_Cyrus; 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_Cyrus 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, unsigned *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); if (count != 1) rc = SASL_FAIL; else { rsv = POPs; if (SvOK(rsv)) { // we have to check for undef return values if ( (*result = strdup(SvPV(rsv, *len))) == NULL) rc = SASL_FAIL; } else { *result = strdup(""); } } /* Final cleanup of the stack, since we may've pop'd one */ PUTBACK ; /* Remember to delete temporary variables */ FREETMPS ; LEAVE ; } return rc; } /* This function wraps sasl_getsimple_t function pointers for perl. Name is taken from earlier versions, which made no difference between Callback types */ int PerlCallback(void *context, int id, const char **result, unsigned *len) { struct _perlcontext *cp = (struct _perlcontext *) context; int llen, rc=SASL_OK; char *c = NULL; if (id != SASL_CB_USER && id != SASL_CB_AUTHNAME && id != SASL_CB_LANGUAGE) { croak("Authen::SASL::Cyrus: Don't know how to handle callback: %x\n", id); rc = -1; } else rc = PerlCallbackSub(cp,&c,&llen,NULL); // Execute PerlCode _DEBUG("simple Callback returns: %s %d",c,llen); if (rc == SASL_OK) { if (result != NULL) *result = strdup(c); if (len != NULL) *len = llen; } if (c != NULL) free(c); return rc; } int PerlCallbackRealm ( void *context, int id, const char **availrealms, const char **result) { struct _perlcontext *cp = (struct _perlcontext *) context; int rc = SASL_OK,i,len; char *c = NULL; AV *args = newAV(); // Create the array if (availrealms != NULL) for (i=0; availrealms[i] != NULL; i++) { _DEBUG("added available realm: %s",availrealms[i]); av_push(args, newSVpv(availrealms[i],0)); } /* HandlePerlStuff */ rc = PerlCallbackSub(cp,&c,&len,args); // Clear the array av_clear(args); av_undef(args); if (rc == SASL_OK) { if (result != NULL) *result = strdup(c); else rc = -1; } if (c != NULL) free(c); return 1; } int FillSecret_t(char * p,int len, sasl_secret_t **psecret) { int rc = SASL_OK; sasl_secret_t *pass; // Allocate sasl password stuff pass = (sasl_secret_t *) malloc( len + sizeof(sasl_secret_t) + 1); // 1 for \0 if (pass == NULL) rc=SASL_FAIL; else { // and fill it _DEBUG("passlen: %d, %s",len,p); pass->len = len; strncpy( (char *)pass->data,p,len); pass->data[len] = '\0'; _DEBUG("passlen: %d, %s",pass->len,pass->data); *psecret = pass; } return rc; } /* This function wraps the sasl_getsecret_t function pointer for perl */ int PerlCallbackSecret (sasl_conn_t *conn, void *context, int id, sasl_secret_t **psecret) { struct _perlcontext *cp = (struct _perlcontext *) context; int len,rc = SASL_OK; char *c = NULL; /* HandlePerlStuff */ rc = PerlCallbackSub(cp,&c,&len,NULL); if (rc == SASL_OK && psecret != NULL) { rc = FillSecret_t(c,len,psecret); } else rc = SASL_FAIL; if (c != NULL) free(c); return rc; } int PerlCallbackCanonUser(sasl_conn_t *conn, void *context, const char *user, unsigned ulen, unsigned flags, const char *user_realm, char *out_user, unsigned out_umax, unsigned *out_ulen) { struct _perlcontext *cp = (struct _perlcontext *) context; int rc = SASL_OK,len; char *c = NULL; AV *args; _DEBUG("Enter CanonUser user(%s,%d) user_realm(%s) out_user(%s) out_umax(%d).",user,ulen,user_realm,out_user,out_umax); if (!(flags & SASL_CU_AUTHID) && !(flags & SASL_CU_AUTHZID)) return SASL_BADPARAM; args = newAV(); // Create the parameter array and fill it av_push(args, newSVpv(user,ulen)); av_push(args, newSViv(out_umax)); av_push(args, newSVpv(user_realm == NULL ? "" : user_realm,0)); av_push(args, newSVpv(flags & SASL_CU_AUTHID ? "AUTHID" : "AUTHZID" ,0)); /* HandlePerlStuff */ rc = PerlCallbackSub(cp,&c,&len,args); // Clear the array av_clear(args); av_undef(args); *out_ulen = len > out_umax ? out_umax : len; strncpy(out_user,c,*out_ulen); if (c != NULL) free(c); return rc; } #ifdef SASL2 /* This function wraps the sasl_server_userdb_checkpass_t function pointer for perl. */ int PerlCallbackServerCheckPass(sasl_conn_t *conn, void *context, const char *user, const char *pass, unsigned passlen, struct propctx *propctx) { struct _perlcontext *cp = (struct _perlcontext *) context; int rc = SASL_OK,len; char *c = NULL; AV *args = newAV(); // Create the parameter array and fill it av_push(args, newSVpv(pass,0)); av_push(args, newSVpv(user,0)); _DEBUG("ServerCheckPass %s %s",user,pass); /* HandlePerlStuff */ rc = PerlCallbackSub(cp,&c,&len,args); // Clear the array av_clear(args); av_undef(args); rc = strcmp(c,"1") == 0 ? SASL_OK : SASL_FAIL; if (c != NULL) free(c); _DEBUG("Checkpass retval: %d",rc); return rc; } int PerlCallbackServerSetPass(sasl_conn_t *conn, void *context, const char *user, const char *pass, unsigned passlen, struct propctx *propctx, unsigned flags) { struct _perlcontext *cp = (struct _perlcontext *) context; AV *args = newAV(); int rc = SASL_OK, len; char *c = NULL; _DEBUG("ServerSetPass: %s, %s, %d",user,pass,passlen); av_push(args,newSViv(flags)); if (passlen == 0) av_push(args,newSVpv("",0)); else av_push(args,newSVpv(pass,passlen)); av_push(args,newSVpv(user,0)); rc = PerlCallbackSub(cp,&c,&len,args); av_clear(args); av_undef(args); _DEBUG("PerlCallback returns: %s,%d",c,rc); if (c != NULL) free(c); return rc; } int PerlCallbackAuthorize( sasl_conn_t *conn, void *context, const char *requested_user, unsigned rlen, const char *auth_identity, unsigned alen, const char *def_realm, unsigned urlen, struct propctx *propctx ) { struct _perlcontext *cp = (struct _perlcontext *) context; AV *args = newAV(); int rc = SASL_OK,len; char *c = NULL; _DEBUG("Authorize: %s, %s, %s",auth_identity,requested_user,def_realm); // Create the parameter array and fill it av_push(args, newSVpv(auth_identity,alen)); av_push(args, newSVpv(requested_user,rlen)); // av_push(args, newSVpv(def_realm, urlen)); /* HandlePerlStuff */ rc = PerlCallbackSub(cp,&c,&len,args); // Clear the array av_clear(args); av_undef(args); rc = strcmp(c,"1") == 0 ? SASL_OK : SASL_FAIL; if (c != NULL) free(c); _DEBUG("Authorize: %x",rc); return rc; } #else // Callbacks for SASL 1 (from version 1.5.28) int PerlCallbackCanonUser1( void *context, const char *auth_identity, const char *requested_user, const char **user, const char **errstr) { int rc = SASL_OK,len; char *c = malloc(sizeof(char) * 256); if (c != NULL) strcpy(c,""); else return SASL_FAIL; _DEBUG("%s,%s",auth_identity,requested_user); if (strcmp(auth_identity,requested_user)) rc = PerlCallbackCanonUser(NULL,context,requested_user,strlen(requested_user),SASL_CU_AUTHZID,"",c,255,&len); rc = PerlCallbackCanonUser(NULL,context,auth_identity,strlen(auth_identity),SASL_CU_AUTHID,"",c,255,&len); *user = strdup(c); if (c != NULL) free(c); return rc; } int PerlCallbackAuthorize( void *context, const char *auth_identity, const char *requested_user, const char **user, const char **errstr) { struct _perlcontext *cp = (struct _perlcontext *) context; int rc = SASL_OK,len; AV *args; char *c = NULL; // SASL1 canonuser workaround if (sp_canon != NULL) { PerlCallbackCanonUser1( sp_canon, auth_identity, requested_user,(const char**) &c, errstr); free(c); // Throw away c = NULL; } _DEBUG("Authorize: %s, %s",auth_identity,requested_user); 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,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::Cyrus allows Cyrus-SASL to use perl-variables and perl-subs as callback-targets. Currently Authen::SASL::Cyrus supports the following Callback types: (for a more detailed description on what the callback type is used for see the respective man pages) B: All callbacks, which have to return some values (e.g.: **result in C) 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 from the library. Input: none Output: C, C or C =item password (client) =item pass (client) This callbacks represent the C from the library. Input: none Output: C =item realm This callback represents the C 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 from the library. Input: C, C Output: true or false =item getsecret (server, SASL v1 only) This callback represents the C from the library. Sasl will check if the passwords are matching. Input: C, C, C Output: C B: 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 from the library. Input: C, C, C and maximal allowed length of the output. Output: canonicalised C C is "AUTHID" for Authentication ID or "AUTHZID" for Authorisation ID. B: This callback is ideal to get the username of the user using your service. If C 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 from the library. Input: C, C, (C SASL v2 only) Output: C 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 from the library. Input: C, C, C (0x01 CREATE, 0x02 DISABLE, 0x04 NOPLAIN) Out: true or false =back =head2 Ways to pass a callback Authen::SASL::Cyrus 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 => */ __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 %x callback.\n", cb->id); break; } _DEBUG("Callback: %x",cb->id); /* Write the C SASL callbacks */ switch (cb->id) { case SASL_CB_USER: case SASL_CB_AUTHNAME: case SASL_CB_LANGUAGE: cb->proc = PerlCallback; break; case SASL_CB_PASS: cb->proc = PerlCallbackSecret; break; case SASL_CB_GETREALM: cb->proc = PerlCallbackRealm; break; case SASL_CB_ECHOPROMPT: case SASL_CB_NOECHOPROMPT: break; case SASL_CB_PROXY_POLICY: cb->proc = PerlCallbackAuthorize; break; case SASL_CB_CANON_USER: cb->proc = PerlCallbackCanonUser; break; #ifdef SASL2 case SASL_CB_SERVER_USERDB_CHECKPASS: cb->proc = PerlCallbackServerCheckPass; break; case SASL_CB_SERVER_USERDB_SETPASS: cb->proc = PerlCallbackServerSetPass; break; #else // SASL 1 Servercallbacks: case SASL_CB_SERVER_GETSECRET: cb->proc = 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_Cyrus sasl) { char *key; int count=0,i; long 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_Cyrus *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; if (*sasl == NULL) { // Initialize the given sasl *sasl = (Authen_SASL_Cyrus) malloc (sizeof(struct authensasl)); if (*sasl == NULL) croak("Out of memory\n"); memset(*sasl, 0, sizeof(struct authensasl)); } (*sasl)->is_client = client; (*sasl)->additional_errormsg = NULL; (*sasl)->error_code = 0; if (!host || !*host) { if (client == SASL_IS_CLIENT) SetSaslError((*sasl),SASL_FAIL,"Need a 'hostname' for being a client."); (*sasl)->server = NULL; // When server side is needed, NULL forces sasl to lookup the name. } else (*sasl)->server = strdup(host); if (!service || !*service) { SetSaslError((*sasl),SASL_FAIL,"Need a 'service' name."); (*sasl)->service = NULL; } else (*sasl)->service = strdup(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); _DEBUG("%d, %d, %s",SvTYPE(*hashval),SVt_PV,SvPV_nolen(*hashval)); if (hashval && *hashval && SvTYPE(*hashval) == SVt_PV) { if ((*sasl)->mech) free((*sasl)->mech); (*sasl)->mech = strdup(SvPV_nolen(*hashval)); } else { __DEBUG("Saslmech not recognised:"); } } return (*sasl)->error_code; } #ifdef SASL2 void set_secprop (Authen_SASL_Cyrus 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::Cyrus PACKAGE=Authen::SASL::Cyrus =head1 Authen::SASL::Cyrus 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::Cyrus. 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_Cyrus 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_Cyrus 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::Cyrus. 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: This and the C function are called by L 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 See SYNOPSIS for an example. =cut Authen_SASL_Cyrus 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_Cyrus 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 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_Cyrus sasl; const char *instring; PREINIT: int rc; unsigned outlen,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_Cyrus 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 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_Cyrus sasl char *instring PREINIT: #ifdef SASL2 const char *outstring=NULL; #else char *outstring=NULL; const char *error=NULL; #endif int rc; unsigned int inlen, outlen=0; 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: C, C, C and C 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 and C during negotiation. See example below. =over 4 =cut char * client_step(sasl, instring) Authen_SASL_Cyrus sasl char *instring PPCODE: { #ifdef SASL2 const char *outstring=NULL; #else char *outstring=NULL; #endif int rc; unsigned int inlen, outlen=0; 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 returns a string containing all mechanisms allowed for the user set by C. 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_Cyrus 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 and C is only available when using Cyrus-SASL 2.x library. C sets a new password (depends on the mechanism if the setpass callback is called). C 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_Cyrus 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_Cyrus 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 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_Cyrus 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 and C functions for every traffic which will run over the network after a successful authentication C returns the encrypted string generated from STRING. C 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_Cyrus sasl char *instring PPCODE: { #ifdef SASL2 const char *outstring=NULL; #else char *outstring=NULL; #endif int rc; unsigned int inlen, outlen=0; 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_Cyrus sasl char *instring PPCODE: { #ifdef SASL2 const char *outstring=NULL; #else char *outstring=NULL; #endif int rc; unsigned int inlen, outlen=0; 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_Cyrus 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 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::Cyrus advise is returned if set. After calling the C function, the error code and the special advice are thrown away. =cut char * error(sasl) Authen_SASL_Cyrus 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 returns the current Cyrus-SASL error code. =cut int code(sasl) Authen_SASL_Cyrus sasl CODE: RETVAL=sasl->error_code; OUTPUT: RETVAL =pod =item mechanism ( ) C returns the current used authentication mechanism. =cut char * mechanism(sasl) Authen_SASL_Cyrus sasl CODE: RETVAL = sasl->mech; OUTPUT: RETVAL char * host(sasl, ...) Authen_SASL_Cyrus 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_Cyrus 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_Cyrus 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 returns true if another step is need by the SASL library. Otherwise false is returned. You can also use C but it looks smarter I think. That's why we all using perl, eh? =cut int need_step(sasl) Authen_SASL_Cyrus sasl; CODE: RETVAL = sasl->error_code == SASL_CONTINUE; OUTPUT: RETVAL int property(sasl, ...) Authen_SASL_Cyrus 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((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)); 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; xconn, propnum, value); if (SetSaslError(sasl,rc,"sasl_setprop failed.") != SASL_OK) RETVAL = 1; } } void DESTROY(sasl) Authen_SASL_Cyrus 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::Cyrus 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 => { user => \&getusername, pass => \&getpassword, } ); # Creating the Authen::SASL::Cyrus object my $conn = $sasl->client_new("service", "hostname.domain.tld"); # Client begins always sendreply($conn->client_start()); while ($conn->need_step) { sendreply($conn->client_step( &getreply() ) ); } if ($conn->code == 0) { print STDERR "Negotiation succeeded.\n"; } else { print STDERR "Negotiation failed.\n"; } See t/plain.t for working script. =head1 TESTING I tested ASC (server and client) with the following mechanisms: =over 4 =item GSSAPI Don't forget to create keytab. Non-root keytabs can be specify through $ENV{'KRB5_KTNAME'} (Heimdal >= 0.6, MIT). =item KERBEROS_V4 Available since 0.10, you have to add IPLOCALPORT and IPREMOTEPORT to *_new functions. =item PLAIN =back =head1 SEE ALSO L man pages for sasl_* library functions. =head1 AUTHOR Originally written by Mark Adamson Cyrus-SASL 2.x support by Leif Johansson Glue for server_* and many other structural improvements by Patrick Boettcher Please report any bugs, or post any suggestions, to the authors. =head1 THANKS - Guillaume Filion for testing the server part and for giving hints about some bugs (documentation). - Wolfgang Friebel for bother around with rpm building of test releases. =head1 COPYRIGHT Copyright (c) 2003-5 Patrick Boettcher, DESY Zeuthen. All rights reserved. Copyright (c) 2003 Carnegie Mellon University. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Authen-SASL-Cyrus-0.13-server/Cyrus.pod0100555002635700003130000003220410260737446017761 0ustar pboettchsysprog=head1 NAME Authen::SASL::Cyrus - 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(, , , ); my $conn = $sasl->server_new(, , , ); =head1 DESCRIPTION SASL is a generic mechanism for authentication used by several network protocols. B 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 and C methods. You have to use the C new-constructor to create a SASL object. The C object then holds all necessary variables and callbacks, which you gave when creating the object. C and C will retrieve needed information from this object. =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::Cyrus allows Cyrus-SASL to use perl-variables and perl-subs as callback-targets. Currently Authen::SASL::Cyrus supports the following Callback types: (for a more detailed description on what the callback type is used for see the respective man pages) B: All callbacks, which have to return some values (e.g.: **result in C) 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 from the library. Input: none Output: C, C or C =item password (client) =item pass (client) This callbacks represent the C from the library. Input: none Output: C =item realm This callback represents the C 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 from the library. Input: C, C Output: true or false =item getsecret (server, SASL v1 only) This callback represents the C from the library. Sasl will check if the passwords are matching. Input: C, C, C Output: C B: 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 from the library. Input: C, C, C and maximal allowed length of the output. Output: canonicalised C C is "AUTHID" for Authentication ID or "AUTHZID" for Authorisation ID. B: This callback is ideal to get the username of the user using your service. If C 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 from the library. Input: C, C, (C SASL v2 only) Output: C 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 from the library. Input: C, C, C (0x01 CREATE, 0x02 DISABLE, 0x04 NOPLAIN) Out: true or false =back =head2 Ways to pass a callback Authen::SASL::Cyrus 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; } =head1 Authen::SASL::Cyrus 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::Cyrus. 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". =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::Cyrus. 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: This and the C function are called by L 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 See SYNOPSIS for an example. =pod =item server_start ( CHALLENGE ) C 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. =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. =pod =item server_step ( CHALLENGE ) C performs the next step in the negotiation process. The first parameter you give is the clients challenge/response. =pod =item client_step ( CHALLENGE ) =back B: C, C, C and C 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 and C during negotiation. See example below. =over 4 =pod =item listmech( START , SEPARATOR , END ) C returns a string containing all mechanisms allowed for the user set by C. 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. =pod =item setpass(user, newpassword, oldpassword, flags) =item checkpass(user, password) C and C is only available when using Cyrus-SASL 2.x library. C sets a new password (depends on the mechanism if the setpass callback is called). C 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. =pod =item global_listmech ( ) C is only available when using Cyrus-SASL 2.x library. It returns an array with all mechanisms loaded by the library. =pod =item encode ( STRING ) =item decode ( STRING ) Cyrus-SASL developers suggest using the C and C functions for every traffic which will run over the network after a successful authentication C returns the encrypted string generated from STRING. C returns the decrypted string generated from STRING. It depends on the used mechanism how secure the encryption will be. =pod =item error ( ) C 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::Cyrus advise is returned if set. After calling the C function, the error code and the special advice are thrown away. =pod =item code ( ) C returns the current Cyrus-SASL error code. =pod =item mechanism ( ) C returns the current used authentication mechanism. =pod =item need_step ( ) C returns true if another step is need by the SASL library. Otherwise false is returned. You can also use C but it looks smarter I think. That's why we all using perl, eh? =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::Cyrus 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 => { user => \&getusername, pass => \&getpassword, } ); # Creating the Authen::SASL::Cyrus object my $conn = $sasl->client_new("service", "hostname.domain.tld"); # Client begins always sendreply($conn->client_start()); while ($conn->need_step) { sendreply($conn->client_step( &getreply() ) ); } if ($conn->code == 0) { print STDERR "Negotiation succeeded.\n"; } else { print STDERR "Negotiation failed.\n"; } See t/plain.t for working script. =head1 TESTING I tested ASC (server and client) with the following mechanisms: =over 4 =item GSSAPI Don't forget to create keytab. Non-root keytabs can be specify through $ENV{'KRB5_KTNAME'} (Heimdal >= 0.6, MIT). =item KERBEROS_V4 Available since 0.10, you have to add IPLOCALPORT and IPREMOTEPORT to *_new functions. =item PLAIN =back =head1 SEE ALSO L man pages for sasl_* library functions. =head1 AUTHOR Originally written by Mark Adamson Cyrus-SASL 2.x support by Leif Johansson Glue for server_* and many other structural improvements by Patrick Boettcher Please report any bugs, or post any suggestions, to the authors. =head1 THANKS - Guillaume Filion for testing the server part and for giving hints about some bugs (documentation). - Wolfgang Friebel for bother around with rpm building of test releases. =head1 COPYRIGHT Copyright (c) 2003-5 Patrick Boettcher, DESY Zeuthen. All rights reserved. Copyright (c) 2003 Carnegie Mellon University. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Authen-SASL-Cyrus-0.13-server/Cyrus.pm0100555002635700003130000000133210260737010017574 0ustar pboettchsysprogpackage Authen::SASL::Cyrus; require DynaLoader; require Authen::SASL::Cyrus::Security; require Exporter; @ISA = qw(DynaLoader);# Exporter); $VERSION = "0.13-server"; bootstrap Authen::SASL::Cyrus $VERSION; # # Take a client filehandle and tie it to the Security subclass to # perform SASL encryption and decryption on the network traffic # sub tiesocket { my($sasl, $fh) = @_; new Authen::SASL::Cyrus::Security($fh, $sasl); } # Create a new client filehandle and tie it to the Security subclass to # perform SASL encryption and decryption on the network traffic sub securesocket { my ($sasl, $fh) = @_; my $glob = \do { local *GLOB; }; tie(*$glob, "Authen::SASL::Cyrus::Security", $fh, $sasl); $glob; } 1; Authen-SASL-Cyrus-0.13-server/t/0040755002635700003130000000000010260737467016417 5ustar pboettchsysprogAuthen-SASL-Cyrus-0.13-server/t/plain.t0100555002635700003130000000354010153570161017672 0ustar pboettchsysprog use strict; use Authen::SASL; use Test::Simple tests => 5; our $me; require "t/common.pl"; pipe (FROM_CLIENT,TO_PARENT) or die "pipe failed."; pipe (FROM_PARENT,TO_CLIENT) or die "pipe failed."; my $pid = fork(); my $mech = "PLAIN"; my $service = "arc"; my $host = "hyade11.ifh.de"; if ($pid) { # parent sleep(1); close FROM_PARENT; close TO_PARENT; $me = "server"; my $sasl = Authen::SASL->new ( mechanism => $mech, callback => { canonuser => \&canonuser, authorize => \&authorize, getsecret => \&getsecret, checkpass => \&checkpass, } ) or ok(0); ok(1); my $conn = $sasl->server_new($service) or die "Authen::SASL::Cyrus failed." or ok(0); ok(1); print $conn->listmech("","|",""),"\n"; sendreply( $conn->server_start( getreply(\*FROM_CLIENT) ),\*TO_CLIENT ); ok(1); while ($conn->need_step) { sendreply( $conn->server_step( &getreply(\*FROM_CLIENT) ) ,\*TO_CLIENT ); } if ($conn->code == 0) { ok(1); print "Server: Test successful Negotiation succeeded.\n"; } else { ok(0); print "Server: Negotiation failed.\n",$conn->error(),"\n"; } close FROM_CLIENT; close TO_CLIENT; wait(); } elsif ($pid == 0) { close FROM_CLIENT; close TO_CLIENT; $me = "client"; my $sasl = Authen::SASL->new ( mechanism => $mech, callback => { user => \&getusername, pass => \&getpassword, auth => \&getauthname, } ) or die "Authen::SASL failed."; my $conn = $sasl->client_new($service, $host) or die "Authen::SASL::Cyrus failed."; sendreply($conn->client_start(),*TO_PARENT); while ($conn->need_step) { sendreply($conn->client_step( &getreply(*FROM_PARENT) ),*TO_PARENT ); } if ($conn->code == 0) { print "Client: Negotiation succeeded.\n"; } else { print "Client: Negotiation failed.\n",$conn->error,"\n"; } close FROM_PARENT; close TO_PARENT; exit 0; } else { exit 1; } ok(1); exit 0; Authen-SASL-Cyrus-0.13-server/t/gssapiskel.pl0100444002635700003130000000412310037576527021114 0ustar pboettchsysprog use strict; use Authen::SASL; # After cp'ing and editing this file, remove the line below use Test::More skip_all => "Prepare your GSSAPI enviroment to run this test. see REAME."; use Test::More tests => 5; our $me; require "t/common.pl"; pipe (FROM_CLIENT,TO_PARENT) or die "pipe failed."; pipe (FROM_PARENT,TO_CLIENT) or die "pipe failed."; my $mech = "GSSAPI"; my $service = "service"; my $host = "host"; my $keytab = "keytab_file"; my $pid = fork(); if ($pid) { # parent close FROM_PARENT; close TO_PARENT; $me = "server"; # MIT only or Heimdal >= 0.6 $ENV{'KRB5_KTNAME'} = $keytab if $keytab; my $sasl = Authen::SASL->new ( mechanism => $mech, callback => { checkpass => \&checkpass, getsecret => \&getsecret, canonuser => \&canonuser, authorize => \&authorize, } ) or ok(0); ok(1); my $conn = $sasl->server_new($service) or die "Authen::SASL::Cyrus failed." or ok(0); ok(1); print $conn->listmech("","|",""),"\n"; sendreply( $conn->server_start( getreply(\*FROM_CLIENT) ),\*TO_CLIENT); ok(1); while ($conn->need_step) { sendreply( $conn->server_step( &getreply(\*FROM_CLIENT) ),\*TO_CLIENT); } if ($conn->code == 0) { ok(1); print "Server: Negotiation succeeded.\n"; } else { ok(0); print "Server: Negotiation failed.\n",$conn->error(),"\n"; } sleep(1); close FROM_CLIENT; close TO_CLIENT; wait(); } elsif ($pid == 0) { close FROM_CLIENT; close TO_CLIENT; $me = "client"; my $sasl = Authen::SASL->new ( mechanism => $mech, callback => { user => \&getusername, pass => \&getpassword, auth => \&getauthname, } ) or die "Authen::SASL failed."; my $conn = $sasl->client_new($service, $host) or die "Authen::SASL::Cyrus failed."; sendreply($conn->client_start(),\*TO_PARENT,0); while ($conn->need_step) { sendreply($conn->client_step( &getreply(\*FROM_PARENT) ),\*TO_PARENT); } if ($conn->code == 0) { print "Client: Negotiation succeeded.\n"; } else { print "Client: Negotiation failed.\n",$conn->error,"\n"; } sleep(1); close FROM_PARENT; close TO_PARENT; exit 0; } else { exit 1; } ok(1); exit 0; Authen-SASL-Cyrus-0.13-server/t/common.pl0100444002635700003130000000216510037576527020243 0ustar pboettchsysprog our $me; 1; # Pluginpath #$ENV{'SASL_PATH'} = "/opt/products/sasl/1.5.28/lib/sasl"; sub sendreply { $SIG{PIPE} = 'IGNORE'; # Client is closing too fast my ($s,$so) = @_; $s = " " unless $s; print "$me Sendreply: ",substr($s,0,10),"\n"; syswrite ($so,$s); } sub getreply { my ($so) = @_; my $s; print "$me-Getreply is waiting.\n"; sysread($so,$s,4096); print "$me Getreply: ",substr($s,0,10),"\n"; return $s; } sub checkpass { my ($user,$pass) = @_; print "$me CB Checkpass: $user: $pass\n"; return ($pass eq "klaus"); } sub getsecret { my ($mech,$user,$realm) = @_; print "$me CB Checkpass: $mech, $user, $realm\n"; return "klaus"; } sub canonuser { my ($type,$realm,$maxlen,$user) = @_; print "$me CB Canonuser: $type, $realm, $maxlen, $user\n"; return $user; } sub authorize { my ($username,$req_user) = @_; print "$me CB Authorize: $username, $req_user\n"; # return $username; return 1; } sub getusername { print "$me CB username.\n"; return $ENV{'USER'}; } sub getauthname { print "$me CB authname.\n"; return $ENV{'USER'}; } sub getpassword { print "$me CB password.\n"; return "klaus"; } Authen-SASL-Cyrus-0.13-server/lib/0040755002635700003130000000000010260737467016722 5ustar pboettchsysprogAuthen-SASL-Cyrus-0.13-server/lib/Authen/0040755002635700003130000000000010260737467020146 5ustar pboettchsysprogAuthen-SASL-Cyrus-0.13-server/lib/Authen/SASL/0040755002635700003130000000000010260737467020710 5ustar pboettchsysprogAuthen-SASL-Cyrus-0.13-server/lib/Authen/SASL/Cyrus/0040755002635700003130000000000010260737467022015 5ustar pboettchsysprogAuthen-SASL-Cyrus-0.13-server/lib/Authen/SASL/Cyrus/Security.pm0100555002635700003130000000477410153570161024157 0ustar pboettchsysprog# # Add SASL encoding/decoding to a filehandle # package Authen::SASL::Cyrus::Security; sub TIEHANDLE { my($class, $fh, $conn) = @_; my($ref); $ref->{fh} = $fh; $ref->{conn} = $conn; bless($ref,$class); return($ref); } sub FILENO { my($ref) = @_; return(fileno($ref->{fh})); } sub READ { my($ref, $buf, $len, $offset) = @_; my($need, $didread, $fh, $rc, $cryptbuf, $clearbuf); $fh = $ref->{fh}; $buf = \$_[1]; # Check if there's leftovers from a previous READ $need = $len; if ($ref->{readbuf}) { # If there's enough in the buffer, just take from there if (length($ref->{readbuf}) >= $len) { substr($$buf, $offset, $len) = substr($ref->{readbuf}, 0, $len); $ref->{readbuf} = substr($ref->{readbuf}, $len); return($len); } # Not enough. Take all of the buffer, and read more substr($$buf, $offset, $len) = $ref->{readbuf}; $didread = length($ref->{readbuf}); $need -= $didread; $offset += $didread; $ref->{readbuf} = ""; } # Read in bytes from the socket, and decrypt it $rc = sysread($fh, $cryptbuf, $len); return($didread) if ($rc <= 0); $clearbuf = $ref->{conn}->decode($cryptbuf); return(-1) if not defined ($clearbuf); # It may be that more encrypted bytes are needed to decrypt an entire "block" # If decode() returned nothing, read in more bytes (arbitrary amounts) until # an entire encrypted block is available to decrypt. while ($clearbuf eq "") { $rc = sysread($fh, $cryptbuf, 8); return($rc) if ($rc <= 0); $clearbuf = $ref->{conn}->decode($cryptbuf); return(-1) if not defined ($clearbuf); } # Copy what was asked for, stash the rest substr($$buf, $offset, $need) = substr($clearbuf, 0, $need); $ref->{readbuf} = substr($clearbuf, $need); return($len); } # Encrypting a write() to a filehandle is much easier than reading, because # all the data to be encrypted is immediately available sub WRITE { my($ref,$string,$len) = @_; my($fh, $clearbuf, $cryptbuf); $fh = $ref->{fh}; $clearbuf = substr($string, 0, $len); $cryptbuf = $ref->{conn}->encode($clearbuf); print $fh $cryptbuf; } # Given a GLOB ref, tie the filehandle of the GLOB to this class sub new { my($class, $fh, $conn) = @_; tie(*{$fh}, $class, $fh, $conn); } # Forward close to the tied handle sub CLOSE { my($ref) = @_; close($ref->{fh}); $ref->{fh} = undef; } # Avoid getting too circular in the free'ing of an object in this class. sub DESTROY { my($self) = @_; delete($self->{fh}); undef $self; } 1; Authen-SASL-Cyrus-0.13-server/MANIFEST0100444002635700003130000000033710037576527017303 0ustar pboettchsysprogCyrus.pm Cyrus.xs Cyrus.pod MANIFEST CHANGES Makefile.PL typemap lib/Authen/SASL/Cyrus/Security.pm t/plain.t t/common.pl t/gssapiskel.pl README META.yml Module meta-data (added by MakeMaker) Authen-SASL-Cyrus-0.13-server/typemap0100444002635700003130000000061510260736632017544 0ustar pboettchsysprogTYPEMAP Authen_SASL_Cyrus T_PTROBJ_SPECIAL const char * T_PV INPUT T_PTROBJ_SPECIAL if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/_/::/g; \$ntt}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not of type ${(my $ntt=$ntype)=~s /_/::/g;\$ntt}\") OUTPUT T_PTROBJ_SPECIAL sv_setref_pv($arg, \"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\", (void*)$var); Authen-SASL-Cyrus-0.13-server/README0100555002635700003130000000421710227171671017026 0ustar pboettchsysprogAuthen::SASL::Cyrus - XS code to glue Perl SASL to Cyrus SASL 1. Build Authen::SASL::Cyrus First of all you need Authen::SASL installed at least in version 2.06 (with server patch or higher). Then run the Makefile.PL: If you want to link it with SASL v1 library: # perl Makefile.PL LIBS="-lsasl" if your SASL library is located in another path: # perl Makefile.PL INC=-I/opt/products/sasl/1.5.28/include \ ? LIBS="-L/opt/products/sasl/1.5.28/lib -lsasl" If you want to link it with SASL v2 library: # perl Makefile.PL LIBS="-lsasl2" DEFINE="-DSASL2" if your SASL library is located in another path: # perl Makefile.PL INC=-I/opt/products/sasl/2.1.15/include \ ? LIBS="-L/opt/products/sasl/2.1.15/lib -lsasl2" DEFINE="-DSASL2" (Make sure that you set --with-plugin-dir correct when compiling Cyrus SASL or that you point the enviroment variable SASL_PATH to the correct plugin directory before starting make test or your application) After successful Makefile creation run # make # make test # make install (for a successful make test you have to have installed the PLAIN mechanism) And everything is installed. If you want to test gssapi functionality, copy the gssapiskel.pl to gssapi.t and edit the file correctly. Don't forget the create keytabfiles. Then rerun make test and see what happens. 2. Use Authen::SASL::Cyrus with GSSAPI for LDAP If you are able to use the ldap* tools with GSSAPI and now you want to use Perl for this LDAP work, then you need Authen::SASL::Cyrus 0.11 or later. Please try this script before reporting any bugs or problems: #!/usr/bin/perl -w use Net::LDAP; use Authen::SASL; my $slavesasl = Authen::SASL->new(mechanism=>'GSSAPI' 'user' => " ", # empty callback, so Net::LDAP don't overrides it ); my $ldap = Net::LDAP->new('server', version=>3, async=>1) || die "$@"; my $mesg = $ldap->bind("", sasl=>$slavesasl, async=>1); $mesg->code && die $mesg->error; $mesg = $ldap->search(async=>1,filter=>"(objectClass=*)",base=>"dc=workgroup"); @entries = $mesg->entries; foreach $entry (@entries) { $entry->dump; } ## If you discover any problem please report the error message, your SASL version and your LDAP version to me. Authen-SASL-Cyrus-0.13-server/Makefile.PL0100555002635700003130000000121410227165133020106 0ustar pboettchsysprog# Do yourself a favour, and don't edit this file, see README for build instructions use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Authen::SASL::Cyrus', 'VERSION_FROM' => 'Cyrus.pm', 'PREREQ_PM' => { Test::Simple => 0, Test::More => 0, Authen::SASL => 2.08, }, ); package MY; sub manifypods { return <<'POD'; manifypods: Cyrus.pod Cyrus.pod: Cyrus.xs @echo "!!! Developers: Do not edit the Cyrus.pod, edit the Cyrus.xs instead. !!!" @echo "Make will overwrite Cyrus.pod." podselect Cyrus.xs > Cyrus.pod POD }