Apache-SdnFw
12 results

 view release on metacpan or  search on metacpan

lib/Apache/SdnFw/lib/Core.pm  view on Meta::CPAN 

	$out->{GS}{6} = $gs_id;
	$out->{GS}{7} = 'X';
	$out->{GS}{8} = '004010';

	$out->{IEA}{1}++;

	$out->{GE}{1} = 0; # populate our trailing group
	$out->{GE}{2} = $out->{GS}{6};
}

sub x12_add_st {
	my $s = shift;
	my $document = shift;
	my $id = shift;
	my $out = shift;

	my $st_id = $s->db_insert('edi_st',{
		edi_gs_id => $out->{edi_gs_id},
		document => $document,
		document_id => $id,
		},'edi_st_id');

	$out->{ST}{1} = $document;
	$out->{ST}{2} = $st_id;
	$out->{GE}{1}++;

	$out->{SE}{1} = 2; # include the ST and SE to start with
	$out->{SE}{2} = $st_id;
}

sub x12_add_segment {
	my $s = shift;
	my $code = shift;
	my $data = shift;
	my $out = shift;

	croak "Missing code" unless($code);
	croak "Data is not hash ref" unless(ref $data eq 'HASH');
	
	$data->{key} = $code;
	push @{$out->{segments}}, $data;

	$out->{SE}{1}++;
}

sub sync_x12 {
	my $s = shift;
	my $vendor = shift;

	croak "Unknown ftp type for that vendor" unless ($vendor->{ftp_type});
	croak "Unknown local working directory for that vendor" unless($vendor->{local_path});
	croak "Could not find local inbox for vendor" unless(-e "$vendor->{local_path}/inbox");
	#croak "Could not find local outbox for vendor" unless(-e "$vendor->{local_path}/outbox");

	my $ftp;
	if ($vendor->{ftp_type} eq 'ftps') {
		eval "use Net::FTPSSL";
		if ($@) { croak "$@"; }

		my ($server,$port) = split ':', $vendor->{ftp_server};
		print "Logging into $server : $port : $vendor->{ftp_username} : $vendor->{ftp_password}\n" if ($s->{v});
		$port = '21' unless($port);
		$ftp = Net::FTPSSL->new($server,
			Port => $port,
			useSSL => 1,
			Debug => 2,
			) 
			|| die "Can not connect to $vendor->{ftp_server}: $@";
		$ftp->login($vendor->{ftp_username},$vendor->{ftp_password}) 
			|| die "Login failed to $vendor->{ftp_server}: $@";

		print "Connected\n" if ($s->{v});
		my @dirs = $ftp->nlst();

		foreach my $d (@dirs) {
			if ($d =~ m/^(outbox|outgoing)$/i) {
				$ftp->cwd($d) || die "Error cwd to $d: ", $ftp->message;
				foreach my $f ($ftp->nlst()) {
					print "Downloading $f to inbox\n" if ($s->{v});
					$ftp->get($f,"$vendor->{local_path}/inbox/$f") || die "Error get $f: ",
						$ftp->message;
					$ftp->delete($f) || die "Error delete $f: ",
						$ftp->message;
				}
			}
		}
	} elsif ($vendor->{ftp_type} eq 'ftp') {
		print "Logging into $vendor->{ftp_server}\n" if ($s->{v});
		$ftp = Net::FTP->new($vendor->{ftp_server}) 
			|| die "Can not connect to $vendor->{ftp_server}: $@";
		$ftp->login($vendor->{ftp_username},$vendor->{ftp_password}) 
			|| die "Login failed to $vendor->{ftp_server}: $@";
	
		print "Connected\n" if ($s->{v});
		my @dirs = $ftp->ls();

		foreach my $d (@dirs) {
			if ($d =~ m/^(outbox|outgoing)$/i) {
				$ftp->cwd($d) || die "Error cwd to $d: ", $ftp->message;
				foreach my $f ($ftp->ls()) {
					print "Downloading $f to inbox\n" if ($s->{v});
					$ftp->get($f,"$vendor->{local_path}/inbox/$f") || die "Error get $f: ",
						$ftp->message;
					$ftp->delete($f) || die "Error delete $f: ",
						$ftp->message;
				}
			}
		}
	} else {
		croak "Unknwon ftp type $vendor->{ftp_type}";
	}

}

sub send_x12 {
	my $s = shift;
	my $document_code = shift;
	my $text = shift;
	my $edi_vendor_id = shift;
	my $edi_trans_id = shift;

	if (!$edi_trans_id && $document_code ne '997') {
		$edi_trans_id = $s->db_insert('edi_transactions',{
			filename => 'n/a',
			},'edi_trans_id');
	}

	croak "Missing edi_vendor_id" unless($edi_vendor_id);
	#croak "Missing edi_trans_id" unless($edi_trans_id);
	croak "Missing document_code" unless($document_code);
	croak "No text to send" unless($text);

	my %hash = $s->db_q("
		SELECT *
		FROM edi_vendors_v
		WHERE edi_vendor_id=?
		",'hash',
		v => [ $edi_vendor_id ]);

	croak "Invalid edi_vendor $edi_vendor_id" unless($hash{edi_vendor_id});

	if ($s->{env}{DEV}) {
		foreach my $k (qw(ftp_username ftp_server ftp_password ftp_path)) {
			$hash{$k} = $hash{"test_$k"} if ($hash{"test_$k"});
		}
	}

	my $ext = $hash{fileext} || '.edi';
	my $filename = "$hash{filepre}$document_code-$edi_trans_id-$s->{datetime}{ymdhms}$ext";

	if ($hash{ftp_type} eq 'ftps') {
		open F, ">/tmp/$filename";
		print F $text;
		close F;

		eval { _ftps_file(\%hash,$filename); };

		if ($@) {
			print STDERR "$@";
			$s->db_q("UPDATE edi_transactions SET error_msg=?, filename=?
				WHERE edi_trans_id=?
				",undef,
				v => [ $@, $filename, $edi_trans_id ])
				unless($document_code eq '997');
		} else {
			$s->db_q("UPDATE edi_transactions SET success=TRUE, filename=?
				WHERE edi_trans_id=?
				",undef,
				v => [ $filename, $edi_trans_id ])
				unless($document_code eq '997');
		}

		unlink "/tmp/$filename";
	} elsif ($hash{ftp_type} eq 'ftp') {
		open F, ">/tmp/$filename";
		print F $text;
		close F;

		eval { _ftp_file(\%hash,$filename); };
		if ($@) {
			print STDERR "$@";
			$s->db_q("UPDATE edi_transactions SET error_msg=?, filename=?
				WHERE edi_trans_id=?
				",undef,
				v => [ $@, $filename, $edi_trans_id ])
				unless($document_code eq '997');
		} else {
			$s->db_q("UPDATE edi_transactions SET success=TRUE, filename=?
				WHERE edi_trans_id=?
				",undef,
				v => [ $filename, $edi_trans_id ])
				unless($document_code eq '997');
		}

		unlink "/tmp/$filename";
	} elsif ($hash{local_path}) {
		open F, ">/$hash{local_path}/outbox/$filename";
		print F $text;
		close F;

		$s->db_q("UPDATE edi_transactions SET success=TRUE, filename=?
			WHERE edi_trans_id=?
			",undef,
			v => [ "$hash{local_path}/outbox/$filename", $edi_trans_id ])
			unless($document_code eq '997');
	} else {
		print $text;
	}
}

sub _ftps_file {
	my $hash = shift;
	my $filename = shift;

	eval "use Net::FTPSSL";
	if ($@) { croak "$@"; }

	my ($server,$port) = split ':', $hash->{ftp_server};
	$port = '21' unless($port);
	my $ftp = Net::FTPSSL->new($server,
		Port => $port,
		) 
		|| die "Can not connect to $hash->{ftp_server}: $@";
	$ftp->login($hash->{ftp_username},$hash->{ftp_password}) 
		|| die "Login failed to $hash->{ftp_server}: $@";

	if ($hash->{ftp_path}) {
		print "CWD $hash->{ftp_path}\n";
		$ftp->cwd($hash->{ftp_path}) || die "Error cwd to $hash->{ftp_path}: ",$ftp->message;
	}

	my @dirs = $ftp->nlst();

	foreach my $f (@dirs) {
		$f =~ s/^\.\///;
		if ($f =~ m/^(inbox|incoming)$/i) {
			$ftp->cwd($f) || die "Error cwd to $f: ", $ftp->message;
			#print "was going to put $filename to $hash->{ftp_server}\n";
			$ftp->put("/tmp/$filename") || die "Failed to put $filename: ", $ftp->message;
			return 1;
		}
	}

	die "Did not find inbox/incoming on $hash->{ftp_server}";
}

sub _ftp_file {
	my $hash = shift;
	my $filename = shift;

	my $ftp = Net::FTP->new($hash->{ftp_server}) || die "Can not connect to $hash->{ftp_server}: $@";
	$ftp->login($hash->{ftp_username},$hash->{ftp_password}) || die "Login failed to $hash->{ftp_server}: $@";

	if ($hash->{ftp_path}) {
		#print "CWD $hash->{ftp_path}\n";
		$ftp->cwd($hash->{ftp_path}) || die "Error cwd to $hash->{ftp_path}: ",$ftp->message;
	}

	my @dirs = $ftp->ls();

	foreach my $f (@dirs) {
		$f =~ s/^\.\///;
		#print "Checking $f\n";
		if ($f =~ m/^(inbox|incoming)$/i) {
			$ftp->cwd($f) || die "Error cwd to $f: ", $ftp->message;
			#print "was going to put $filename to $hash->{ftp_server}\n";
			$ftp->put("/tmp/$filename") || die "Failed to put $filename: ", $ftp->message;
			return 1;
		}
	}

	die "Did not find inbox/incoming on $hash->{ftp_server}";
}

sub edi_post {

=head2 edi_post

 my $data = $s->edi_post($ref,$url,$data);

=cut

	my $s = shift;
	my $ref = shift;
	my $url = shift;
	my $data = shift;

	my $server = ($s->{env}{DEV})
		? $ref->{sdn_dev_url}
		: $ref->{sdn_url};
	
	croak "Unknown sdn_url" unless($server);

	my $ua = new LWP::UserAgent;
	$ua->timeout(5);
	my $dump = new XML::Dumper;
	my $xml = $dump->pl2xml($data);
	my $req = new HTTP::Request('POST' => "$server$url");
	$req->content_type('application/x-www-form-urlencoded');
	$req->content('<?xml version="1.0" encoding="UTF-8"?>'.$xml);
	my $resp = $ua->request($req);
	my $rxml;
	if ($resp->is_success) {
		my $rxml = $dump->xml2pl($resp->content);
		if (defined($rxml->{data})) {
			return $rxml->{data};
		} elsif (defined($rxml->{error})) {
			$s->alert("Error from $server: $rxml->{error}");
			return undef;
		}
	} else {
		$s->alert("Connection error to $server$url: ".$resp->status_line);

lib/Apache/SdnFw/lib/Core.pm  view on Meta::CPAN 

	my $name = shift;
	my $class = shift;

	my $c = qq( class="$class") if ($class);

	return qq(<input type="submit" value="$name"$c>);
}

sub html_radio {

=head2 html_radio

 my $html = $s->html_radio($key,$value,[$checked],[$desc],[$id]);

=cut

	my $s = shift;
	my $key = $s->escape(shift);
	my $value = $s->escape(shift);
	my $checked = shift;
	my $desc = shift;
	my $id = shift;

	$key = "$s->{acfb}::$key" if ($s->{acfb});

	my $str = qq(<input type="radio" name="$key" value="$value");
	$str .= ' checked' if ($checked eq $value);
	$str .= qq( id="$id") if ($id);
	$str .= '>';
	$str .= " $desc" if ($desc);

	return $str;
}

sub html_checkbox {

=head2 html_checkbox

 my $html = $s->html_checkbox($key,$value,[$checked],[$desc],[$id]);

=cut

	my $s = shift;
	my $key = $s->escape(shift);
	my $value = $s->escape(shift);
	my $checked = shift;
	my $desc = shift;
	my $id = shift;

	$key = "$s->{acfb}::$key" if ($s->{acfb});

	my $str = qq(<input type="checkbox" name="$key" value="$value");
	$str .= ' checked' unless ($checked eq undef);
	$str .= qq( id="$id") if ($id);
	$str .= '>';
	$str .= " $desc" if ($desc);

	return $str;
}

sub html_password {

=head2 html_password

 my $html = $s->html_password($key,$value,[$size]);

=cut

	my $s = shift;
	my $key = $s->escape(shift);
	my $value = $s->escape(shift);
	my $size = shift;

	$key = "$s->{acfb}::$key" if ($s->{acfb});

	my $str = qq(<input type="password" name="$key" value="$value" autocomplete="off");
	$str .= qq( size="$size") if ($size);
	$str .= '>';

	return $str;
}

sub html_upload {

=head2 html_upload

 my $html = $s->html_upload($key,[$size],[$class],[$id]);

=cut

	my $s = shift;
	my $key = $s->escape(shift);
	my $size = shift;
	my $class = shift;
	my $id = shift;

	$key = "$s->{acfb}::$key" if ($s->{acfb});

	my $str = qq(<input type="file" name="$key");
	$str .= qq( size="$size") if ($size);
	$str .= qq( id="$id") if ($id);
	$str .= qq( class="$class") if ($class);
	$str .= '>';

	return $str;
}

sub html_input_email {

=head2 html_input_email

 my $html = $s->html_input_email($key,$value,[$size]);

=cut
	my $s = shift;
	my $key = $s->escape(shift);
	my $value = $s->escape(shift);
	my $size = shift;
	my $class = shift;
	my $id = shift;

	$key = "$s->{acfb}::$key" if ($s->{acfb});

	my $str = qq(<input type="email" name="$key" value="$value" autocomplete="off");
	$str .= qq( size="$size") if ($size);
	$str .= qq( id="$id") if ($id);
	$str .= qq( class="$class") if ($class);
	$str .= '>';

	return $str;
}

sub html_input_number {

=head2 html_input_number

lib/Apache/SdnFw/lib/Core.pm  view on Meta::CPAN 


	if (ref $s->{title} eq 'ARRAY') {
		my $t = join ' :: ', @{$s->{title}};
		$s->{title} = $t;
	}

	if ($s->{env}{TITLE}) {
		if ($s->{title}) {
			$s->{title} = "$s->{env}{TITLE} :: $s->{title}";
		} else {
			$s->{title} = $s->{env}{TITLE};
		}
	}

	$s->{title} = $s->{uri} unless($s->{title});

	return "<title>$s->{title}</title>\n";
}

sub _interface_auth {
	my $s = shift;

	# make sure we have some things
	croak "id not defined in object $s->{object}" unless($s->{o}{id});
	croak "table not defined in object $s->{object}" unless($s->{o}{table});
	croak "view not defined in object $s->{object}" unless($s->{o}{view});
	croak "interface not defined in object $s->{object}" unless($s->{o}{interface});

	if ($s->{object} eq 'logout' && $s->{cookies}{IL}) {
		$s->db_q("
			UPDATE $s->{o}{table} SET interface_cookie=NULL
			WHERE interface_cookie=?
			",undef,
			v => [ $s->{cookies}{IL} ],
			);

		#$s->{raw_path} = '/';
		#$s->{uri} =~ s/logout//;
	}

	SWITCH: {
		last if ($s->_interface_check_cookie());
		last if ($s->_interface_check_login());
	}

	#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>";

	return 1 if ($s->{$s->{o}{id}});

	$s->{nomenu} = 1; 
	$s->{title} = 'Login';

	$s->tt('interface_login.tt',{ s => $s });

	return 0;
}

sub _interface_check_login {
	my $s = shift;

	if ($s->{in}{interface_email} && $s->{in}{interface_password}) {
		$s->{in}{interface_email} = lc $s->{in}{interface_email};
		my %hash = $s->db_q("
			SELECT *
			FROM $s->{o}{view}
			WHERE interface_email=?
			",'hash',
			v => [ $s->{in}{interface_email} ],
			);

		my $md5pass;
		if ($s->{env}{DEV}) {
			# skip password checking on dev
			$md5pass = $hash{interface_password};
		} else {
			$md5pass = md5_hex($hash{interface_email}.$s->{in}{interface_password});
		}

		if ($md5pass eq $hash{interface_password}) {
			my $cookie = $s->_interface_cookie_key(
				id => $hash{$s->{o}{id}},
				password => $hash{interface_password},
				);
			$s->{$s->{o}{id}} = $hash{$s->{o}{id}};
			$s->{$s->{o}{interface}} = { %hash };
			push @{$s->{r}{set_cookie}}, "IL=$cookie; path=/;";
			$s->db_update_key($s->{o}{table},$s->{o}{id},$hash{$s->{o}{id}},{
				interface_cookie => $cookie,
				});
			return 1;
		} else {
			$s->{error}{login} = "Invalid password";
		}
	}

	return 0;
}

sub _interface_check_cookie {
	my $s = shift;

	if ($s->{cookies}{IL}) {
		my %hash = $s->db_q("
			SELECT *
			FROM $s->{o}{view}
			WHERE interface_cookie=?
			",'hash',
			v => [ $s->{cookies}{IL} ],
			);

		if ($hash{$s->{o}{id}}) {
			my $validate = $s->_interface_cookie_key(
				id => $hash{$s->{o}{id}},
				password => $hash{interface_password},
				);

			if ($validate eq $s->{cookies}{IL}) {
				$s->{$s->{o}{id}} = $hash{$s->{o}{id}};
				$s->{$s->{o}{interface}} = { %hash };
				return 1;
			} else {
				push @{$s->{r}{set_cookie}}, 'IL=; path=/;';
				$s->db_update_key($s->{o}{table},$s->{o}{id},$hash{$s->{o}{id}},{
					interface_cookie => '',
					});
			}
		} else {
			push @{$s->{r}{set_cookie}}, 'IL=; path="/";';
		}
	}

	return 0;
}

sub _interface_cookie_key {
	my $s = shift;
	my %args = @_;

	my $expire;
	if ($s->{env}{ETERNAL_COOKIE}) {
		$expire = $s->{server_name}; # just add a little more to try and make this unique
	} else {
		$expire = time2str('%x',time());
	}
	return md5_hex("84Fw$args{id}YouSuck$args{passwd}7f2$expire");
}

sub _employee_permissions {
	my $s = shift;

	# build a data structure we can use in add_action to determine if
	# we should even show something to someone

	# first get a list of all actions that are not assigned to a group
	# which means everyone can do them
	# then append to this the actions that this specific person can do
	my @list = $s->db_q("
		SELECT a.a_object, a.a_function
		FROM actions a
			LEFT JOIN group_actions ga ON a.action_id=ga.action_id
		WHERE ga.group_id IS NULL
		UNION
		SELECT a.a_object, a.a_function
		FROM employee_groups eg
			JOIN group_actions ga ON eg.group_id=ga.group_id
			JOIN actions a ON ga.action_id=a.action_id
		WHERE eg.employee_id=?
		",'arrayhash',
		c => "employeepermission$s->{employee_id}",
		cache_for => '60',
		v => [ $s->{employee_id} ]);

	# now, from this list, lets make a data structure we can use
	foreach my $ref (@list) {
		$s->{employee}{object}{$ref->{a_object}}{$ref->{a_function}} = 1;
	}
}

sub _authenticate {
	my $s = shift;

	if ($s->{in}{forgot_email}) {
		if ($s->verify_email(\$s->{in}{forgot_email})) {
			my %employee = $s->db_q("
				SELECT *
				FROM employees
				WHERE email=?
				",'hash',
				v => [ $s->{in}{forgot_email} ]);

			if ($employee{employee_id}) {
				my $new = int(rand(1)*100000);
				$s->db_q("
					UPDATE employees SET passwd=?
					WHERE employee_id=?
					",undef,
					v => [ $new, $employee{employee_id} ]);

				$s->sendmail(to => $employee{email},
					from => 'root@'.$s->{server_name},
					subject => 'Password Reset',
					body => "Your password at $s->{server_name} has has been reset\n\n".
						"username: $employee{login}\n".
						"password: $new\n\n".
						"Please login, and then go change your password.");

				$s->{error}{login} = "Your password has been reset and sent to $employee{email}";
			} else {
				$s->{error}{login} = "Unknown email";
				$s->{in}{forgot} = 1;
			}
		} else {
			$s->{error}{login} = "That is not a valid email";
			$s->{in}{forgot} = 1;
		}
	}	

	if ($s->{object} eq 'logout' && $s->{cookies}{L}) {
		$s->db_q("
			UPDATE employees SET cookie=NULL
			WHERE cookie=?
			",undef,
			v => [ $s->{cookies}{L} ],
			);

		#$s->{raw_path} = '/';
		#$s->{uri} =~ s/logout//;
	}

	SWITCH: {
		last if ($s->_check_api());
		last if ($s->_check_cookie());
		last if ($s->_check_login());
	}

	#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>";

	return 1 if ($s->{employee_id});

	$s->{nomenu} = 1; 
	$s->{title} = 'Login';

	unless($s->{in}{ori_args}) {
		$s->{in}{ori_args} = $s->{args};
	}

	if ($s->{in}{forgot}) {
		$s->tt('forgot.tt',{ s => $s });
	} else {
		$s->tt('login.tt',{ s => $s });
	}

	return 0;
}

sub _check_login {
	my $s = shift;

	if ($s->{in}{login} && $s->{in}{passwd}) {
		my %hash = $s->db_q("
			SELECT *
			FROM employees_v_login
			WHERE lower(login)=lower(?)
			",'hash',
			v => [ $s->{in}{login} ],
			);

		my $md5pass = md5_hex($hash{login}.$s->{in}{passwd});
		if ($md5pass eq $hash{passwd} && !$hash{account_expired}) {
			my $cookie = $s->_cookie_key(
				employee_id => $hash{employee_id},
				passwd => $hash{passwd},
				);
			$s->{employee_id} = $hash{employee_id};
			$s->{employee} = { %hash };
			_employee_permissions($s);
			push @{$s->{r}{set_cookie}}, "L=$cookie; path=/;";
			$s->db_update_key('employees','employee_id',$hash{employee_id},{
				cookie => $cookie,
				});
			# now, populate args
			if ($s->{in}{ori_args}) {
				foreach my $kv (split '&', $s->{in}{ori_args}) {
					my ($k,$v) = split '=', $kv;
					$v =~ tr/+/ /;
					$v =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
					$s->{in}{$k} = $v;
				}
			}

			return 1;
		} else {
			$s->{error}{login} = "Invalid password or login";
		}
	} elsif ($s->{env}{IP_LOGIN}) {
		my %hash = $s->db_q("
			SELECT *
			FROM employees_v_login
			WHERE ip_addr>>=?
			",'hash',
			v => [ $s->{remote_addr} ],
			);

		if ($hash{employee_id} && !$hash{account_expired}) {
			my $cookie = $s->_cookie_key(
				employee_id => $hash{employee_id},
				passwd => $hash{passwd} || $hash{ip_addr},
				);
			$s->{employee_id} = $hash{employee_id};
			$s->{employee} = { %hash };
			_employee_permissions($s);
			push @{$s->{r}{set_cookie}}, "L=$cookie; path=/;";
			$s->db_update_key('employees','employee_id',$hash{employee_id},{
				cookie => $cookie,
				});
			# now, populate args
			if ($s->{in}{ori_args}) {
				foreach my $kv (split '&', $s->{in}{ori_args}) {
					my ($k,$v) = split '=', $kv;
					$v =~ tr/+/ /;
					$v =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
					$s->{in}{$k} = $v;
				}
			}

			return 1;
		}
	}

	return 0;
}

sub _check_api {
	my $s = shift;

	if ($s->{in}{key}) {
		my $employee_id = $s->db_q("
			SELECT employee_id
			FROM employees
			WHERE apikey=?
			AND COALESCE(expired_ts,now()) >= now()
			",'scalar',
			c => "apikey$s->{in}{key}",
			cache_for => '60',
			v => [ $s->{in}{key} ]);

		if ($employee_id) {
			$s->{employee_id} = $employee_id;
			%{$s->{employee}} = $s->db_q("
				SELECT *
				FROM employees_v_login
				WHERE employee_id=?
				",'hash',



( run in 0.622 second using v1.01-cache-2.11-cpan-df04353d9ac )