diff options
Diffstat (limited to 'LedgerSMB')
| -rw-r--r-- | LedgerSMB/Form.pm | 8 | ||||
| -rw-r--r-- | LedgerSMB/IS.pm | 112 | ||||
| -rwxr-xr-x | LedgerSMB/Session/DB.pm | 71 | ||||
| -rw-r--r-- | LedgerSMB/Sysconfig.pm | 22 | ||||
| -rw-r--r-- | LedgerSMB/User.pm | 100 |
5 files changed, 148 insertions, 165 deletions
diff --git a/LedgerSMB/Form.pm b/LedgerSMB/Form.pm index a98eb0d0..4d055497 100644 --- a/LedgerSMB/Form.pm +++ b/LedgerSMB/Form.pm @@ -1113,9 +1113,17 @@ autocommit disabled. sub db_init { my ( $self, $myconfig ) = @_; + + # Handling of HTTP Basic Auth headers + my $auth = $ENV{'HTTP_AUTHORIZATION'}; + $auth =~ s/Basic //i; # strip out basic authentication preface + $auth = MIME::Base64::decode($auth); + my ($login, $password) = split(/:/, $auth); + $self->{dbh} = $self->dbconnect_noauto($myconfig) || $self->dberror(); my %date_query = ( 'mm/dd/yy' => 'set DateStyle to \'SQL, US\'', + 'mm-dd-yy' => 'set DateStyle to \'POSTGRES, US\'', 'dd/mm/yy' => 'set DateStyle to \'SQL, EUROPEAN\'', 'dd-mm-yy' => 'set DateStyle to \'POSTGRES, EUROPEAN\'', diff --git a/LedgerSMB/IS.pm b/LedgerSMB/IS.pm index 264fbd29..d494eb48 100644 --- a/LedgerSMB/IS.pm +++ b/LedgerSMB/IS.pm @@ -1527,6 +1527,12 @@ sub process_assembly { } sub cogs { + # This is nearly entirely rewritten since 1.2.8 based in part on the works + # of Victor Sterpu and Dieter Simader (see CONTRIBUTORS for more + # information). However, there are a number of areas where I have + # substantially rewritten the logic. This function is heavily annotated + # largely because COGS/invoices are still scheduled to be re-engineered in + # 1.4 so it is a good idea to have records of opinions in the code.-- CT my ( $dbh2, $form, $id, $totalqty, $project_id, $sellprice) = @_; my $dbh = $form->{dbh}; my $query; @@ -1606,13 +1612,13 @@ sub cogs { # will throw an error until we have an understanding of other workflows # that need to be supported. -- CT $query = qq| - SELECT i.id, i.qty, i.allocated, a.transdate - i.qty - i.allocated AS available, + SELECT i.id, i.qty, i.allocated, a.transdate, + -1 * (i.allocated + i.qty) AS available, p.expense_accno_id, p.inventory_accno_id FROM invoice i JOIN parts p ON (p.id = i.parts_id) JOIN ar a ON (a.id = i.trans_id) - WHERE i.parts_id = ? AND (i.qty + i.allocated) > 0 + WHERE i.parts_id = ? AND (i.qty + i.allocated) > 0 AND i.sellprice = ? ORDER BY transdate |; @@ -1621,7 +1627,7 @@ sub cogs { my $qty; while ( my $ref = $sth->fetchrow_hashref(NAME_lc) ) { $form->db_parse_numeric(sth=>$sth, hashref => $ref); - if ($totalqty > $ref->{available}){ + if ($totalqty < $ref->{available}){ $qty = $ref->{available}; } else { $qty = $totalqty; @@ -1629,44 +1635,86 @@ sub cogs { # update allocated for sold item $form->update_balance( $dbh, "invoice", "allocated", - qq|id = $ref->{id}|, $qty * -1 + qq|id = $ref->{id}|, $qty ); - $allocated += $qty; - my $linetotal = $qty*$ref->{sellprice}; - $query = qq| - INSERT INTO acc_trans - (trans_id, chart_id, amount, - transdate, project_id, invoice_id) - VALUES (?, ?, ?, ?, ?, ?)|; - - my $sth1 = $dbh->prepare($query); - $sth1->execute( - $form->{id}, $ref->{"expense_accno_id"}, - $linetotal, $form->{transdate}, - $project_id, $ref->{id} - ) || $form->dberror($query); - $query = qq| - INSERT INTO acc_trans - (trans_id, chart_id, amount, transdate, - project_id, invoice_id) - VALUES (?, ?, ?, ?, ?, ?)|; - - $sth1 = $dbh->prepare($query); - $sth1->execute( - $form->{id}, $ref->{"inventory_accno_id"}, - -$linetotal, $form->{transdate}, - $project_id, $ref->{id} - ) || $form->dberror($query); + # Note: No COGS calculations on reversed short sale invoices. + # This merely prevents COGS calculations in the future agaisnt + # such short invoices. -- CT $totalqty -= $qty; + $allocated -= $qty; last if $totalqty == 0; } + # If the total quantity is still less than zero, we must assume that + # this is just an invoice which has been voided or products returns + # but is not merely representing a voided short sale, and therefore + # we need to unallocate the items from AP. There has been some debate + # as to how to approach this, and I think it is safest to unallocate + # the most recently allocated AP items of the same type regardless of + # the relevant dates of the invoices. I can see cases where this + # might require adjustments, however. -- CT + + if ($totalqty < 0){ + $query = qq| + SELECT i.allocated, i.sellprice, p.inventory_accno_id, + p.expense_accno_id, i.id + FROM invoice i + JOIN parts p ON (i.parts_id = p.id) + JOIN ap a ON (i.trans_id = a.id) + WHERE (i.allocated + i.qty) < 0 + AND i.parts_id = ? + ORDER BY a.transdate DESC, a.id DESC + |; + + my $sth = $dbh->prepare($query); + $sth->execute($id); + + while (my $ref = $sth->fetchrow_hashref(NAME_lc)){ + my $qty = $ref->{allocated} * -1; + + $qty = ($qty < $totalqty) ? $totalqty : $qty; + + my $linetotal = $qty*$ref->{sellprice}; + push @{ $form->{acc_trans}{lineitems} }, + { + chart_id => $ref->{expense_accno_id}, + amount => $linetotal, + project_id => $project_id, + invoice_id => $ref->{id} + }; + + push @{ $form->{acc_trans}{lineitems} }, + { + chart_id => $ref->{inventory_accno_id}, + amount => -$linetotal, + project_id => $project_id, + invoice_id => $ref->{id} + }; + $form->update_balance( + $dbh, "invoice", "allocated", + qq|id = $ref->{id}|, $qty + ); + + $totalqty -= $qty; + $allocated -= $qty; + + last if $totalqty == 0; + } + } + + # If we still have less than 0 total quantity, this is not a return + # or a void. Throw an error. If there are valid workflows that throw + # this error, they will require more work to address and will not work + # safely with the current system. -- CT if ($totalqty < 0){ $form->error("Too many reversed items on an invoice"); } + elsif ($totalqty > 0){ + $form->error("Unexpected and invalid quantity allocated.". + " Aborting."); + } } - return $allocated; } diff --git a/LedgerSMB/Session/DB.pm b/LedgerSMB/Session/DB.pm index 872dd419..145e1476 100755 --- a/LedgerSMB/Session/DB.pm +++ b/LedgerSMB/Session/DB.pm @@ -28,16 +28,21 @@ # (ver. < 1.2) and the md5 one (ver. >= 1.2) #==================================================================== package Session; +use MIME::Base64; +use strict; sub session_check { use Time::HiRes qw(gettimeofday); my ( $cookie, $form ) = @_; - my ( $sessionID, $transactionID, $token ) = split /:/, $cookie; + if ($cookie eq 'Login'){ + return session_create($form); + } + my $timeout; - # use the central database handle - my $dbh = ${LedgerSMB::Sysconfig::GLOBALDBH}; + + my $dbh = $form->{dbh}; my $checkQuery = $dbh->prepare( "SELECT u.username, s.transaction_id @@ -54,6 +59,10 @@ sub session_check { WHERE session_id = ?;" ); + my ($sessionID, $transactionID, $company) = split(/:/, $cookie); + + $form->{company} ||= $company; + #must be an integer $sessionID =~ s/[^0-9]//g; $sessionID = int $sessionID; @@ -61,15 +70,11 @@ sub session_check { $transactionID =~ s/[^0-9]//g; $transactionID = int $transactionID; - #must be 32 chars long and contain hex chars - $token =~ s/[^0-9a-f]//g; - $token = substr( $token, 0, 32 ); - - if ( !$myconfig{timeout} ) { + if ( !$form->{timeout} ) { $timeout = "1 day"; } else { - $timeout = "$myconfig{timeout} seconds"; + $timeout = "$form->{timeout} seconds"; } $checkQuery->execute( $sessionID, $timeout ) @@ -99,8 +104,8 @@ sub session_check { || $form->dberror( __FILE__ . ':' . __LINE__ . ': Updating session age: ' ); - $newCookieValue = - $sessionID . ':' . $newTransactionID . ':' . $token; + my $newCookieValue = + $sessionID . ':' . $newTransactionID . ':' . $form->{company}; #now update the cookie in the browser print qq|Set-Cookie: LedgerSMB=$newCookieValue; path=/;\n|; @@ -129,6 +134,8 @@ sub session_check { } sub session_create { + my ($lsmb) = @_; + my $lsmb; use Time::HiRes qw(gettimeofday); @@ -136,7 +143,6 @@ sub session_create { my ( $ignore, $newTransactionID ) = gettimeofday(); $newTransactionID = int $newTransactionID; - my ($form) = @_; if ( !$ENV{HTTP_HOST} ) { @@ -145,7 +151,7 @@ sub session_create { } # use the central database handle - my $dbh = ${LedgerSMB::Sysconfig::GLOBALDBH}; + my $dbh = $lsmb->{dbh}; # TODO Change this to use %myconfig my $deleteExisting = $dbh->prepare( @@ -167,43 +173,56 @@ sub session_create { WHERE username = ?), ?, ?);" ); -# this is assuming that $form->{login} is safe, which might be a bad assumption -# so, I'm going to remove some chars, which might make previously valid logins invalid - my $login = $form->{login}; +# this is assuming that the login is safe, which might be a bad assumption +# so, I'm going to remove some chars, which might make previously valid +# logins invalid --CM + +# I am changing this to use HTTP Basic Auth credentials for now. -- CT + + my $auth = $ENV{HTTP_AUTHORIZATION}; + $auth =~ s/^Basic //i; + my ($login, undef) = split(/:/, MIME::Base64::decode($auth)); $login =~ s/[^a-zA-Z0-9._+\@'-]//g; #delete any existing stale sessions with this login if they exist - if ( !$myconfig{timeout} ) { - $myconfig{timeout} = 86400; + if ( $lsmb->{timeout} ) { + $lsmb->{timeout} = 86400; } - $deleteExisting->execute( $login, "$myconfig{timeout} seconds" ) - || $form->dberror( + $deleteExisting->execute( $login, "$lsmb->{timeout} seconds" ) + || $lsmb->dberror( __FILE__ . ':' . __LINE__ . ': Delete from session: ' ); #doing the random stuff in the db so that LedgerSMB won't -#require a good random generator - maybe this should be reviewed, pgsql's isn't great either +#require a good random generator - maybe this should be reviewed, +#pgsql's isn't great either -CM +# +#I think we should be OK. The random number generator is only a small part +#of the credentials in 1.3.x, and for people that need greater security, there +#is always Kerberos.... -- CT $fetchSequence->execute() - || $form->dberror( __FILE__ . ':' . __LINE__ . ': Fetch sequence id: ' ); + || $lsmb->dberror( __FILE__ . ':' . __LINE__ . ': Fetch sequence id: ' ); my ( $newSessionID, $newToken ) = $fetchSequence->fetchrow_array; #create a new session $createNew->execute( $newSessionID, $login, $newToken, $newTransactionID ) - || $form->dberror( __FILE__ . ':' . __LINE__ . ': Create new session: ' ); + || $lsmb->dberror( __FILE__ . ':' . __LINE__ . ': Create new session: ' ); #reseed the random number generator my $randomSeed = 1.0 * ( '0.' . ( time() ^ ( $$ + ( $$ << 15 ) ) ) ); $seedRandom->execute($randomSeed) - || $form->dberror( + || $lsmb->dberror( __FILE__ . ':' . __LINE__ . ': Reseed random generator: ' ); - $newCookieValue = $newSessionID . ':' . $newTransactionID . ':' . $newToken; + + my $newCookieValue = $newSessionID . ':' . $newTransactionID . ':' + . $lsmb->{company}; #now set the cookie in the browser #TODO set domain from ENV, also set path to install path print qq|Set-Cookie: LedgerSMB=$newCookieValue; path=/;\n|; - $form->{LedgerSMB} = $newCookieValue; + $lsmb->{LedgerSMB} = $newCookieValue; } sub session_destroy { diff --git a/LedgerSMB/Sysconfig.pm b/LedgerSMB/Sysconfig.pm index e01618cc..b62651a6 100644 --- a/LedgerSMB/Sysconfig.pm +++ b/LedgerSMB/Sysconfig.pm @@ -116,17 +116,17 @@ for $var (qw(DBhost DBport DBname DBUserName DBPassword)) { } #putting this in an if clause for now so not to break other devel users -if ( $config{globaldb}{DBname} ) { - my $dbconnect = "dbi:Pg:dbname=$globalDBname host=$globalDBhost - port=$globalDBport user=$globalDBUserName - password=$globalDBPassword"; # for easier debugging - $GLOBALDBH = DBI->connect($dbconnect); - if ( !$GLOBALDBH ) { - $form = new Form; - $form->error("No GlobalDBH Configured or Could not Connect"); - } - $GLOBALDBH->{pg_enable_utf8} = 1; -} +#if ( $config{globaldb}{DBname} ) { +# my $dbconnect = "dbi:Pg:dbname=$globalDBname host=$globalDBhost +# port=$globalDBport user=$globalDBUserName +# password=$globalDBPassword"; # for easier debugging +# $GLOBALDBH = DBI->connect($dbconnect); +# if ( !$GLOBALDBH ) { +# $form = new Form; +# $form->error("No GlobalDBH Configured or Could not Connect"); +# } +# $GLOBALDBH->{pg_enable_utf8} = 1; +#} # These lines prevent other apps in mod_perl from seeing the global db # connection info diff --git a/LedgerSMB/User.pm b/LedgerSMB/User.pm index 89033ed1..41aa0dcd 100644 --- a/LedgerSMB/User.pm +++ b/LedgerSMB/User.pm @@ -165,14 +165,15 @@ sub fetch_config { #I'm hoping that this function will go and is a temporary bridge #until we get rid of %myconfig elsewhere in the code - my ( $self, $login ) = @_; + my ( $self, $lsmb ) = @_; + + my $login = $lsmb->{login}; + my $dbh = $lsmb->{dbh}; if ( !$login ) { &error( $self, "Access Denied" ); } - # use central db - my $dbh = ${LedgerSMB::Sysconfig::GLOBALDBH}; # for now, this is querying the table directly... ugly # my $fetchUserPrefs = $dbh->prepare( @@ -230,99 +231,6 @@ sub fetch_config { return \%myconfig; } -=item $user->login($form); - -Disused auth function. - -=cut - -sub login { - - my ( $self, $form ) = @_; - - my $rc = -1; - - if ( $self->{login} ne "" ) { - if ( - !Session::password_check( - $form, $form->{login}, $form->{password} - ) - ) - { - return -1; - } - - #this is really dumb, but %myconfig will have to stay until 1.3 - while ( my ( $key, $value ) = each( %{$self} ) ) { - $myconfig{$key} = $value; - } - - # check if database is down - my $dbh = - DBI->connect( $myconfig{dbconnect}, $myconfig{dbuser}, - $myconfig{dbpasswd} ) - or $self->error( __FILE__ . ':' . __LINE__ . ': ' . $DBI::errstr ); - $dbh->{pg_enable_utf8} = 1; - - # we got a connection, check the version - my $query = qq| - SELECT value FROM defaults - WHERE setting_key = 'version'|; - my $sth = $dbh->prepare($query); - $sth->execute || $form->dberror( __FILE__ . ':' . __LINE__ . $query ); - - my ($dbversion) = $sth->fetchrow_array; - $sth->finish; - - # add login to employee table if it does not exist - # no error check for employee table, ignore if it does not exist - my $login = $self->{login}; - $login =~ s/@.*//; - $query = qq|SELECT entity_id FROM employee WHERE login = ?|; - $sth = $dbh->prepare($query); - $sth->execute($login); - - my ($id) = $sth->fetchrow_array; - $sth->finish; - - if ( !$id ) { - my ($employeenumber) = - $form->update_defaults( \%myconfig, "employeenumber", $dbh ); - - $query = qq| - INSERT INTO employee - (login, employeenumber, name, - workphone, role) - VALUES (?, ?, ?, ?, ?)|; - $sth = $dbh->prepare($query); - $sth->execute( - $login, $employeenumber, $myconfig{name}, - $myconfig{tel}, $myconfig{role} - ); - } - $dbh->disconnect; - - $rc = 0; - - if ( $form->{dbversion} ne $dbversion ) { - $rc = -3; - $dbupdate = - ( calc_version($dbversion) < calc_version( $form->{dbversion} ) ); - } - - if ($dbupdate) { - $rc = -4; - - # if DB2 bale out - if ( $myconfig{dbdriver} eq 'DB2' ) { - $rc = -2; - } - } - } - - $rc; - -} =item LedgerSMB::User->check_recurring($form); |