[dw-free] Finishing up payment system
[commit: http://hg.dwscoalition.org/dw-free/rev/d6ec125e3d2b]
http://bugs.dwscoalition.org/show_bug.cgi?id=116
This is a checkpoint commit, the shop is non-functional still, it doesn't
let you do much more other than mess around with your shopping cart.
There's a lot of backend functionality for shops and carts and items. The
very boring pages in this patch show how to work the backend functions.
ALSO, it is hereby acknowledged that some percentage of this is DW-specific
and needs to be moved to a better location and made more generic. But since
we want the store interface to be dw-free, this is going here first so it
gets the right licensing explicitly.
Patch by
mark.
Files modified:
http://bugs.dwscoalition.org/show_bug.cgi?id=116
This is a checkpoint commit, the shop is non-functional still, it doesn't
let you do much more other than mess around with your shopping cart.
There's a lot of backend functionality for shops and carts and items. The
very boring pages in this patch show how to work the backend functions.
ALSO, it is hereby acknowledged that some percentage of this is DW-specific
and needs to be moved to a better location and made more generic. But since
we want the store interface to be dw-free, this is going here first so it
gets the right licensing explicitly.
Patch by
![[staff profile]](https://www.dreamwidth.org/img/silk/identity/user_staff.png)
Files modified:
- bin/upgrading/update-db-general.pl
- cgi-bin/DW/Logic/MenuNav.pm
- cgi-bin/DW/Pay.pm
- cgi-bin/DW/Shop.pm
- cgi-bin/DW/Shop/Cart.pm
- cgi-bin/DW/Shop/Item/Account.pm
- cgi-bin/DW/Widget/PaidAccountStatus.pm
- cgi-bin/DW/Widget/ShopCartStatusBar.pm
- cgi-bin/LJ/User.pm
- cgi-bin/LJ/Widget.pm
- cgi-bin/ljlib.pl
- etc/config.pl
- htdocs/shop.bml
- htdocs/shop.bml.text
- htdocs/shop/account.bml
- htdocs/shop/cart.bml
- htdocs/stc/widgets/shop.css
-------------------------------------------------------------------------------- diff -r 317e748df4b3 -r d6ec125e3d2b bin/upgrading/update-db-general.pl --- a/bin/upgrading/update-db-general.pl Sun Apr 05 03:53:44 2009 +0000 +++ b/bin/upgrading/update-db-general.pl Sun Apr 05 06:33:21 2009 +0000 @@ -3166,6 +3166,23 @@ CREATE TABLE email_aliases ( ) EOC +# shopping cart list +register_tablecreate('shop_carts', <<'EOC'); +CREATE TABLE shop_carts ( + cartid INT UNSIGNED NOT NULL, + starttime INT UNSIGNED NOT NULL, + userid INT UNSIGNED, + uniq VARCHAR(15) NOT NULL, + state INT UNSIGNED NOT NULL, + + cartblob MEDIUMBLOB NOT NULL, + + PRIMARY KEY (cartid), + INDEX (userid), + INDEX (uniq) +) +EOC + # NOTE: new table declarations go ABOVE here ;) diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Logic/MenuNav.pm --- a/cgi-bin/DW/Logic/MenuNav.pm Sun Apr 05 03:53:44 2009 +0000 +++ b/cgi-bin/DW/Logic/MenuNav.pm Sun Apr 05 06:33:21 2009 +0000 @@ -55,6 +55,7 @@ sub get_menu_navigation { my $loggedin_canjoincomms = ( $loggedin && $u->is_person ) ? 1 : 0; # note the semantic difference my $loggedout = $loggedin ? 0 : 1; my $always = 1; + my $never = 0; my @nav = ( { @@ -184,6 +185,16 @@ sub get_menu_navigation { }, ], }, + { + name => 'shop', + items => [ + { + url => "$LJ::SITEROOT/shop?for=paidtime", + text => "menunav.shop.paidtime", + display => $never, + }, + ], + }, ); return \@nav; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Pay.pm --- a/cgi-bin/DW/Pay.pm Sun Apr 05 03:53:44 2009 +0000 +++ b/cgi-bin/DW/Pay.pm Sun Apr 05 06:33:21 2009 +0000 @@ -1,7 +1,24 @@ package DW::Pay; +#!/usr/bin/perl +# +# DW::Pay +# +# Core of the payment system. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2008-2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# + package DW::Pay; use strict; +use Carp qw/ confess /; use HTTP::Request; use LWP::UserAgent; @@ -280,32 +297,31 @@ sub pp_confirm_order { ################################################################################ # DW::Pay::type_is_valid # -# ARGUMENTS: type +# ARGUMENTS: typeid # -# type required the id of the type we're checking +# typeid required the id of the type we're checking # # RETURN: 1/0 if the type is a valid type # sub type_is_valid { my $type = shift()+0; - return 1 if $type >= 1 && $type <= 2; + return 1 if $LJ::CAP{$_[0]} && $LJ::CAP{$_[0]}->{_account_type}; return 0; } ################################################################################ # DW::Pay::type_name # -# ARGUMENTS: type +# ARGUMENTS: typeid # -# type required the id of the type we're checking +# typeid required the id of the type we're checking # -# RETURN: strin name of type, else undef +# RETURN: string name of type, else undef # sub type_name { - return { - 1 => 'Basic Paid Account', - 2 => 'Premium Paid Account', - }->{ $_[0] } || 'UNKNOWN/ERROR'; + confess 'invalid typeid' + unless DW::Pay::type_is_valid( $_[0] ); + return $LJ::CAP{$_[0]}->{_visible_name}; } ################################################################################ @@ -347,6 +363,24 @@ sub get_paid_status { } ################################################################################ +# DW::Pay::default_typeid +# +# RETURN: typeid of the default account type. +# +sub default_typeid { + # try to get the default cap class. note that we confess here because + # these errors are bad enough to warrant bailing whoever is calling us. + my @defaults = grep { $LJ::CAP{$_}->{_account_default} } keys %LJ::CAP; + confess 'must have one %LJ::CAP class set _account_default to use the payment system' + if scalar( @defaults ) < 1; + confess 'only one %LJ::CAP class can be set as _account_default' + if scalar( @defaults ) > 1; + + # There Can Be Only One + return $defaults[0]; +} + +################################################################################ # DW::Pay::get_current_account_status # # ARGUMENTS: uuserid @@ -356,14 +390,75 @@ sub get_paid_status { # RETURN: undef for free, else a typeid of the account type. # sub get_current_account_status { - DW::Pay::clear_error(); - + # try to get current paid status my $stat = DW::Pay::get_paid_status( @_ ); # free accounts: no row, or expired - return undef unless defined $stat; - return undef unless $stat->{permanent} || $stat->{expiresin} > 0; + return DW::Pay::default_typeid() unless defined $stat; + return DW::Pay::default_typeid() unless $stat->{permanent} || $stat->{expiresin} > 0; + + # valid row, return whatever type it is return $stat->{typeid}; +} + +################################################################################ +# DW::Pay::get_account_expiration_time +# +# ARGUMENTS: uuserid +# +# uuserid required user object or userid to get paid status of +# +# RETURN: -1 for free, 0 for expired paid, else the unix timestamp this +# account expires on... +# +# yes, this function has a very weird return value. :( +# +sub get_account_expiration_time { + # try to get current paid status + my $stat = DW::Pay::get_paid_status( @_ ); + + # free accounts: no row, or expired + return -1 unless defined $stat; + return 0 unless $stat->{permanent} || $stat->{expiresin} > 0; + + # valid row, return whatever the expiration time is + return time() + $stat->{expiresin}; +} + +################################################################################ +# DW::Pay::get_account_type +# +# ARGUMENTS: uuserid +# +# uuserid required user object or userid to get paid status of +# +# RETURN: value defined as _account_type in %LJ::CAP. +# +sub get_account_type { + my $typeid = DW::Pay::get_current_account_status( @_ ); + confess 'account has no valid typeid' + unless $typeid && $typeid > 0; + confess "typeid $typeid not a valid account level" + unless $LJ::CAP{$typeid} && $LJ::CAP{$typeid}->{_account_type}; + return $LJ::CAP{$typeid}->{_account_type}; +} + +################################################################################ +# DW::Pay::get_account_type_name +# +# ARGUMENTS: uuserid +# +# uuserid required user object or userid to get paid status of +# +# RETURN: value defined as _visible_name in %LJ::CAP. +# +sub get_account_type_name { + my $typeid = DW::Pay::get_current_account_status( @_ ); + confess 'account has no valid typeid' + unless $typeid && $typeid > 0; + confess "typeid $typeid not a valid account level" + unless $LJ::CAP{$typeid} && $LJ::CAP{$typeid}->{_visible_name}; + return $LJ::CAP{$typeid}->{_visible_name}; } ################################################################################ @@ -465,8 +560,8 @@ sub update_paid_status { if exists $cols{userid}; return error( ERR_FATAL, "Permanent must be 0/1." ) if exists $cols{permanent} && $cols{permanent} !~ /^(?:0|1)$/; - return error( ERR_FATAL, "Typeid must be some number." ) - if exists $cols{typeid} && $cols{typeid} !~ /^(?:\d+)$/; + return error( ERR_FATAL, "Typeid must be some number and valid." ) + if exists $cols{typeid} && !( $cols{typeid} =~ /^(?:\d+)$/ && DW::Pay::type_is_valid( $cols{typeid} ) ); return error( ERR_FATAL, "Expiretime must be some number." ) if exists $cols{expiretime} && $cols{expiretime} !~ /^(?:\d+)$/; return error( ERR_FATAL, "Lastemail must be 0, 3, or 14." ) @@ -580,35 +675,37 @@ sub pp_do_request { } } + +# this internal method takes a user's paid status (which is the accurate record +# of what caps and things a user should have) and then updates their caps. i.e., +# this method is used to make the user's actual caps reflect reality. sub sync_caps { my $u = LJ::want_user( shift ) or return error( ERR_FATAL, "Must provide a user to sync caps for." ); my $ps = DW::Pay::get_paid_status( $u ); + # calculate list of caps that we care about + my @bits = grep { $LJ::CAP{$_}->{_account_type} } keys %LJ::CAP; + my $default = DW::Pay::default_typeid(); + # either they're free, or they expired (not permanent) if ( ! $ps || ( ! $ps->{permanent} && $ps->{expiresin} < 0 ) ) { - LJ::modify_caps( $u, [], [ 3, 4, 6, 7 ] ); + # reset back to the default, and turn off all other bits; then set the + # email count to defined-but-0 + LJ::modify_caps( $u, [ $default ], [ grep { $_ != $default } @bits ] ); DW::Pay::update_paid_status( $u, lastemail => 0 ); } else { + # this is a really bad error we should never have... we can't + # handle this user + # FIXME: candidate for email-site-admins return error( ERR_FATAL, "Unknown typeid." ) - unless $ps->{typeid} == 1 || $ps->{typeid} == 2; + unless DW::Pay::type_is_valid( $ps->{typeid} ); + # simply modify it to use the typeid specified, as typeids are bits... but + # turn off any other bits + LJ::modify_caps( $u, [ $ps->{typeid} ], [ grep { $_ != $ps->{typeid} } @bits ] ); DW::Pay::update_paid_status( $u, lastemail => undef ); - - if ( $ps->{permanent} ) { - if ( $ps->{typeid} == 1 ) { - LJ::modify_caps( $u, [ 6 ], [ 3, 4, 7 ] ); - } elsif ( $ps->{typeid} == 2 ) { - LJ::modify_caps( $u, [ 7 ], [ 3, 4, 6 ] ); - } - } else { - if ( $ps->{typeid} == 1 ) { - LJ::modify_caps( $u, [ 3 ], [ 4, 6, 7 ] ); - } elsif ( $ps->{typeid} == 2 ) { - LJ::modify_caps( $u, [ 4 ], [ 3, 6, 7 ] ); - } - } } return 1; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Shop.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cgi-bin/DW/Shop.pm Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,129 @@ +#!/usr/bin/perl +# +# DW::Shop +# +# General helper class that defines a shopping session and generally facilitate +# a user interacting with stuff. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# + +package DW::Shop; + +use strict; +use Carp qw/ croak confess /; + +use DW::Shop::Cart; +use DW::Shop::Item::Account; + +# variables we maintain +our $STATE_OPEN = 1; # open carts - user can still modify +our $STATE_CHECKOUT = 2; # carts have gone through checkout (COMPLETED checkout) +our $STATE_PEND_PAID = 3; # waiting on payment confirmation (eCheck?) +our $STATE_PAID = 4; # payment received but cart hasn't been processed +our $STATE_PROCESSED = 5; # we have received payment for this cart +our $STATE_PEND_REFUND = 6; # refund is approved but unissued +our $STATE_REFUNDED = 7; # we have refunded this cart and reversed it +our $STATE_CLOSED = 8; # carts can go from OPEN -> CLOSED + +# documentation of valid state transitions... +# +# OPEN -> CHECKOUT user has decided to purchase this and we have sent the +# payment information to PayPal or Google, but we haven't +# heard back on what's going on +# +# CHECKOUT -> PEND_PAID PP/GC tells us that the user is paying through some +# method that won't let us get the money yet, so we will +# have to hold until we hear back again +# +# PEND_PAID -> PAID both of these transitions indicate that the user has +# CHECKOUT -> PAID really given us the money. i.e., we've got cash in hand +# and we are ready to actually process the cart. +# +# PAID -> PROCESSED after we have processed the cart (i.e., granted the paid +# time, given the points, etc.) this lets us know that the +# cart is now 'done'. +# +# PROCESSED -> PEND_REFUND the user wants a refund and the refund has been +# approved. this is basically a reverse-process step. +# +# PEND_REFUND -> REFUNDED once the processing has been complete and we have +# unapplied everything that we can, we set state. +# +# OPEN -> CLOSED this state is only used if the user has timed out a +# cart. i.e., it hasn't been touched in a while so we +# decide the user isn't coming back. +# +# any other state transition is hereby considered null and void. + + +# called to return an instance of the shop; auto-determines if we have a +# remote user and uses that, else, just returns an anonymous shop +sub get { + my ( $class ) = @_; + + # easy mode: if we have a remote then we can just toss this into the + # bucket and have it be used; this trick works because get_remote and + # such always return the same actual hash within a request + if ( my $u = LJ::get_remote() ) { + return $u->{_shop} ||= bless { userid => $u->id }, $class; + } + + # no remote, so let's note that + return bless { anon => 1 }, $class; +} + + +# returns an active cart, if the user has one +sub cart { + my ( $self ) = @_; + + return DW::Shop::Cart->get( $self ); +} + + +# builds a new cart for the user (throws away existing active) +sub new_cart { + my ( $self ) = @_; + + return DW::Shop::Cart->new_cart( $self ); +} + + +# gets a link to the active user; this is done this way with a load_userid call +# to prevent circular references. (we could just make it a weak reference...?) +# FIXME: explore if LJ uses weak references anywhere and if so we can use them +# to store a weakened-$u in $self in initialize() +sub u { + return undef if $_[0]->{anon} || ! $_[0]->{userid}; + return LJ::load_userid( $_[0]->{userid} ); +} + + +# true if this is an anonymous shopping session +sub anonymous { + return $_[0]->{anon} ? 1 : 0; +} + + +################################################################################ +## LJ::User methods +################################################################################ + +package LJ::User; + +# returns the shop on a user +sub shop { + return $_[0]->{_shop} + or confess 'tried to get shop without calling DW::Shop->initialize()'; +} + + +1; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Shop/Cart.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cgi-bin/DW/Shop/Cart.pm Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,229 @@ +#!/usr/bin/perl +# +# DW::Shop::Cart +# +# Encapsulates a shopping cart for a user. Handles loading, saving, modifying +# and all other actions of a shopping cart. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# + +package DW::Shop::Cart; + +use strict; +use Carp qw/ croak confess /; +use Storable qw/ nfreeze thaw /; + +use DW::Shop; + +# returns a created cart for a given shop +sub get { + my ( $class, $shop ) = @_; + + # see if the shop has a user or if it's anonymous + my ( $u, $sql, @bind ); + if ( $shop->anonymous ) { + # if they don't have a unique cookie and they're anonymous, we aren't + # presently equipped to let them shop + my $uniq = LJ::UniqCookie->current_uniq + or return undef; + + # FIXME: we should memcache carts for people who aren't logged in + + $sql = 'uniq = ? AND userid IS NULL'; + @bind = ( $uniq ); + + } else { + $u = $shop->u + or confess 'shop has no user object'; + + # return this cart if loaded already + return $u->{_cart} if $u->{_cart}; + + # see if this user has an active cart in memcache + my $cart = $u->memc_get( 'cart' ); + return $u->{_cart} = $cart + if $cart; + + # faaail, have to load it + $sql = 'userid = ?'; + @bind = ( $u->id ); + } + + # see if they had one in the database + my $dbh = LJ::get_db_writer() + or return undef; + my $dbcart = $dbh->selectrow_hashref( + qq{SELECT userid, cartid, starttime, uniq, state, cartblob + FROM shop_carts + WHERE $sql AND state = ? + ORDER BY starttime DESC + LIMIT 1}, + undef, @bind, $DW::Shop::STATE_OPEN + ); + + # if we got something, thaw the blob and return + if ( $dbcart ) { + my $cart = $class->_build( thaw( $dbcart->{cartblob} ) ); + if ( $u ) { + $u->{_cart} = $cart; + $u->memc_set( cart => $cart ); + } + return $cart; + } + + # no existing cart, so build a new one \o/ + return $class->new_cart( $u ); +} + + +# creating a new cart implicitly activates. just so you know. this function +# will build a new empty cart for the user. but user is optional and we will +# build a cart for the current uniq. +sub new_cart { + my ( $class, $u ) = @_; + $u = LJ::want_user( $u ); + + my $cartid = LJ::alloc_global_counter( 'H' ) + or return undef; + + # this is a blank cart containing no items + my $cart = { + cartid => $cartid, + starttime => time(), + userid => $u ? $u->id : undef, + uniq => LJ::UniqCookie->current_uniq, + state => $DW::Shop::STATE_OPEN, + items => [], + total => 0.00, + }; + + # build this into an object and activate it + $cart = $class->_build( $cart ); + + # now persist the cart + $cart->save; + $u->{_cart} = $cart if $u; + + # we're done + return $cart; +} + + +# saves the current cart to the database, returns 1/0 +sub save { + my $self = $_[0]; + + # toss in the database + my $dbh = LJ::get_db_writer() + or return undef; + $dbh->do( + q{REPLACE INTO shop_carts (userid, cartid, starttime, uniq, state, cartblob) + VALUES (?, ?, ?, ?, ?, ?)}, + undef, ( map { $self->{$_} } qw/ userid cartid starttime uniq state / ), nfreeze( $self ) + ); + + # bail if error + return 0 if $dbh->err; + + # also toss this in memcache + if ( my $u = LJ::load_userid( $self->{userid} ) ) { + $u->memc_set( cart => $self ); + } + + # success! + return 1; +} + + +# returns 1/0 if this cart has any items in it +sub has_items { + my $self = $_[0]; + + return scalar( @{ $self->{items} || [] } ) > 0 ? 1 : 0; +} + + +# add an item to the shopping cart, returns 1/0 +sub add_item { + my ( $self, $item ) = @_; + + # iterate over existing items to see if any conflict + foreach my $it ( @{$self->items} ) { + if ( my $rv = $it->conflicts( $item ) ) { + # this return value is so messed up... WTB exceptions + return ( 0, $rv ); + } + } + + # looks good, so let's add it... + push @{$self->items}, $item; + $self->{total} += $item->cost; + $item->id( $#{$self->items} ); + + # save to db and return + $self->save; + return 1; +} + + +# removes an item from this cart by id +sub remove_item { + my ( $self, $id ) = @_; + + my $out = []; + foreach my $it ( @{$self->items} ) { + if ( $it->id == $id ) { + $self->{total} -= $it->cost; + } else { + push @$out, $it; + } + } + + $self->{items} = $out; + $self->save; + return 1; +} + + +################################################################################ +## read-only accessor methods +################################################################################ + + +sub id { $_[0]->{cartid} } +sub userid { $_[0]->{userid} } +sub age { time() - $_[0]->{starttime} } +sub items { $_[0]->{items} ||= [] } +sub state { $_[0]->{state} } +sub uniq { $_[0]->{uniq} } +sub total { $_[0]->{total}+0.00 } + +# returns the total in a displayed format +sub display_total { sprintf( '%0.2f', $_[0]->total ) } + + +################################################################################ +## internal cart methods +################################################################################ + + +# turns a hashref cart into a cart object +sub _build { + my ( $class, $cart ) = @_; + ref $cart eq 'HASH' or return $cart; + + # simply blesses ... although in the future we might do some sanity checking + # here to make sure we have good data, if that proves to be necessary. + return bless $cart, $class; +} + + +1; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Shop/Item/Account.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cgi-bin/DW/Shop/Item/Account.pm Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,168 @@ +#!/usr/bin/perl +# +# DW::Shop::Item::Account +# +# Represents a paid account that someone is purchasing. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# + +package DW::Shop::Item::Account; + +use strict; + + +# instantiates an account to be purchased of some sort +sub new { + my ( $class, %args ) = @_; + + my $type = delete $args{type}; + return undef unless exists $LJ::SHOP{$type}; + + # at this point, there needs to be only one argument, and it needs to be one + # of the target types + return undef unless + scalar( keys %args ) == 1 && + ( $args{target_username} || $args{target_userid} || $args{target_email} ); + + # now do validation. since new is only called when the item is being added + # to the shopping cart, then we are comfortable doing all of these checks + # on things at the time this item is put together + if ( my $un = $args{target_username} ) { + # username needs to be valid and not exist + return undef unless $un = LJ::canonical_username( $un ); + return undef if LJ::load_user( $un ); + + $args{target_username} = $un; + + } elsif ( my $uid = $args{target_userid} ) { + # userid needs to exist + return undef unless LJ::load_userid( $uid ); + + } elsif ( my $email = $args{target_email} ) { + # FIXME: validate email address + + } + + # looks good + return bless { + # user supplied arguments (close enough) + cost => $LJ::SHOP{$type}->[0] + 0.00, + months => $LJ::SHOP{$type}->[1], + class => $LJ::SHOP{$type}->[2], + %args, + + # internal things we use to track the state of this item + type => 'account', + applied => 0, + }, $class; +} + + +# called when we are told we need to apply this item, i.e., turn it on. note that we +# update ourselves, but it's up to the cart to make sure that it saves. +sub apply { + my $self = $_[0]; + return if $self->applied; + + # do the application process now, and if it succeeds... + $self->{applied} = 1; + warn "$self->{class} applied $self->{months} months\n"; + + return 1; +} + + +# called when we need to turn this item off +sub unapply { + my $self = $_[0]; + return unless $self->applied; + + # do the application process now, and if it succeeds... + $self->{applied} = 0; + warn "$self->{class} unapplied $self->{months} months\n"; + + return 1; +} + + +# given another item, see if that item conflicts with this item (i.e., +# if you can't have both in your shopping cart at the same time). +# +# returns undef on "no conflict" else an error message. +sub conflicts { + my ( $self, $item ) = @_; + + # first see if we're talking about the same target + # FIXME: maybe not include email here, what happens if they want to buy 3 paid accounts + # and send them to the same email address? + return if + ( $self->t_userid && $self->t_userid != $item->t_userid ) || + ( $self->t_email && $self->t_email != $item->t_email ) || + ( $self->t_username && $self->t_username != $item->t_username ); + + # target same, if either is permanent, then fail because + # THERE CAN BE ONLY ONE + return 'Already purchasing a permanent account for this target.' + if $self->permanent || $item->permanent; + + # otherwise ensure that the classes are the same + return 'Already chose to upgrade to a ' . $self->class . ', do not do both!' + if $self->class ne $item->class; + + # guess we allow it + return undef; +} + + +# render our target as a string +sub t_html { + my $self = $_[0]; + + if ( my $uid = $self->t_userid ) { + my $u = LJ::load_userid( $uid ); + return $u->ljuser_display + if $u; + return "<strong>invalid userid $uid</strong>"; + + } elsif ( my $user = $self->t_username ) { + my $u = LJ::load_user( $user ); + return $u->ljuser_display + if $u; + return "<strong>$user</strong>"; + + } elsif ( my $email = $self->t_email ) { + return "<strong>$email</strong>"; + + } + + return "<strong>invalid/unknown target</strong>"; +} + + +# this is a getter/setter so it is pulled out +sub id { + return $_[0]->{id} unless defined $_[1]; + return $_[0]->{id} = $_[1]; +} + + +# simple accessors +sub applied { return $_[0]->{applied}; } +sub cost { return $_[0]->{cost}; } +sub months { return $_[0]->{months}; } +sub class { return $_[0]->{class}; } +sub t_userid { return $_[0]->{target_userid}; } +sub t_email { return $_[0]->{target_email}; } +sub t_username { return $_[0]->{target_username}; } +sub permanent { return $_[0]->months == 99; } + + +1; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Widget/PaidAccountStatus.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cgi-bin/DW/Widget/PaidAccountStatus.pm Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,52 @@ +#!/usr/bin/perl +# +# DW::Widget::PaidAccountStatus +# +# Renders happy box to show a paid account's status. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# + +package DW::Widget::PaidAccountStatus; + +use strict; +use base qw/ LJ::Widget /; +use Carp qw/ croak /; + +use DW::Pay; +use DW::Shop; + +# general purpose shop CSS used by the entire shop system +sub need_res { qw( stc/widgets/shop.css ) } + +# main renderer for this particular thingy +sub render_body { + my ( $class, %opts ) = @_; + + my $remote = LJ::get_remote() + or return; + + my $account_type = DW::Pay::get_account_type_name( $remote ); + my $expires_at = DW::Pay::get_account_expiration_time( $remote ); + my $expires_on = $expires_at > 0 + ? 'Your paid time expires: ' . LJ::mysql_time( $expires_at ) + : ''; + + my $ret = qq{ +<div class='shop-account-status'> + Your current account type is: <strong>$account_type</strong><br /> + $expires_on +</div> + }; + + return $ret; +} + +1; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/DW/Widget/ShopCartStatusBar.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cgi-bin/DW/Widget/ShopCartStatusBar.pm Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,57 @@ +#!/usr/bin/perl +# +# DW::Widget::ShopCartStatusBar +# +# Renders the status bar used to show someone's status in the shop. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# + +package DW::Widget::ShopCartStatusBar; + +use strict; +use base qw/ LJ::Widget /; +use Carp qw/ croak /; + +use DW::Shop; + +# general purpose shop CSS used by the entire shop system +sub need_res { qw( stc/widgets/shop.css ) } + +# main renderer for this particular thingy +sub render_body { + my ( $class, %opts ) = @_; + + # make sure the shop is initialized + my $shop = DW::Shop->get; + my $u = $shop->u; + + # if they want a new cart, give them one; this is immediate and the + # old cart is gone with the wind ... + my $cart = $opts{newcart} ? DW::Shop::Cart->new_cart( $u ) : $shop->cart; + + # if minimal, and the cart is empty, bail + return if $opts{minimal} && ! $cart->has_items; + + # render out information about this cart + my $ret = '[ '; + $ret .= 'Shopping Cart for ' . ( $u ? $u->ljuser_display : 'anonymous user' ); + $ret .= '; cartid = ' . $cart->id; + $ret .= ' created ' . LJ::ago_text( $cart->age ); + $ret .= '; total = $' . $cart->display_total; + $ret .= '; <a href="/shop?newcart=1">make new cart</a>'; + $ret .= '; <a href="/shop/cart">view cart</a>'; + $ret .= '; <a href="/shop/checkout">checkout</a>'; + $ret .= ' ]'; + + return $ret; +} + +1; diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/LJ/User.pm --- a/cgi-bin/LJ/User.pm Sun Apr 05 03:53:44 2009 +0000 +++ b/cgi-bin/LJ/User.pm Sun Apr 05 06:33:21 2009 +0000 @@ -1201,6 +1201,20 @@ sub log2_do { } +# simple function for getting something from memcache; this assumes that the +# item being gotten follows the standard format [ $userid, "item:$userid" ] +sub memc_get { + return LJ::MemCache::get( [$_[0]->{userid}, "$_[1]:$_[0]->{userid}"] ); +} + + +# sets a predictably named item. usage: +# $u->memc_set( key => 'value', [ $timeout ] ); +sub memc_set { + return LJ::MemCache::set( [$_[0]->{userid}, "$_[1]:$_[0]->{userid}"], $_[2], $_[3] || 1800 ); +} + + sub mysql_insertid { my $u = shift; if ($u->isa("LJ::User")) { diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/LJ/Widget.pm --- a/cgi-bin/LJ/Widget.pm Sun Apr 05 03:53:44 2009 +0000 +++ b/cgi-bin/LJ/Widget.pm Sun Apr 05 06:33:21 2009 +0000 @@ -7,6 +7,7 @@ use LJ::Auth; # FIXME: don't really need all widgets now LJ::ModuleLoader->autouse_subclasses("LJ::Widget"); +LJ::ModuleLoader->autouse_subclasses("DW::Widget"); our $currentId = 1; @@ -96,7 +97,7 @@ sub render { my $ret = "<div class='appwidget appwidget-$css_subclass' id='$widget_ele_id'>\n"; my $rv = eval { - my $widget = ref $class ? $class : "LJ::Widget::$subclass"; + my $widget = $class; # include any resources that this widget declares if (defined $opt_hash{stylesheet_override}) { @@ -124,9 +125,15 @@ sub render { LJ::need_res($opt_hash{stylesheet}) if $opt_hash{stylesheet}; return $widget->render_body(@opts); - } or $class->handle_error($@); + }; - $ret .= $rv; + if ( defined $rv && $rv =~ /\w/ ) { + $ret .= $rv; + } elsif ( $@ ) { + $ret .= "<strong>[Error: $@]</strong"; +# $class->handle_error; + } + $ret .= "</div><!-- end .appwidget-$css_subclass -->\n"; return $ret; @@ -309,7 +316,7 @@ sub subclass { my $class = shift; $class = ref $class if ref $class; return $class unless $class =~ /::/; - return ($class =~ /LJ::Widget::([\w:]+)$/)[0]; + return ($class =~ /(?:LJ|DW)::Widget::([\w:]+)$/)[0]; } # wrapper around BML... for now diff -r 317e748df4b3 -r d6ec125e3d2b cgi-bin/ljlib.pl --- a/cgi-bin/ljlib.pl Sun Apr 05 03:53:44 2009 +0000 +++ b/cgi-bin/ljlib.pl Sun Apr 05 06:33:21 2009 +0000 @@ -2388,7 +2388,7 @@ sub get_secret # LJ-generic domains: # $dom: 'S' == style, 'P' == userpic, 'A' == stock support answer # 'C' == captcha, 'E' == external user, 'O' == school -# 'L' == poLL, 'M' == Messaging +# 'L' == poLL, 'M' == Messaging, 'H' == sHopping cart # sub alloc_global_counter { @@ -2398,8 +2398,7 @@ sub alloc_global_counter # $dom can come as a direct argument or as a string to be mapped via hook my $dom_unmod = $dom; - # Yes, that's a duplicate L in the regex for xtra LOLS - unless ($dom =~ /^[MLOLSPACE]$/) { + unless ($dom =~ /^[ESLPOAHCM]$/) { $dom = LJ::run_hook('map_global_counter_domain', $dom); } return LJ::errobj("InvalidParameters", params => { dom => $dom_unmod })->cond_throw @@ -2432,6 +2431,8 @@ sub alloc_global_counter $newmax = $dbh->selectrow_array("SELECT MAX(ansid) FROM support_answers"); } elsif ($dom eq "O") { $newmax = $dbh->selectrow_array("SELECT MAX(schoolid) FROM schools"); + } elsif ($dom eq "H") { + $newmax = $dbh->selectrow_array("SELECT MAX(cartid) FROM shop_carts"); } elsif ($dom eq "L") { # pick maximum id from poll and pollowner my $max_poll = $dbh->selectrow_array("SELECT MAX(pollid) FROM poll"); diff -r 317e748df4b3 -r d6ec125e3d2b etc/config.pl --- a/etc/config.pl Sun Apr 05 03:53:44 2009 +0000 +++ b/etc/config.pl Sun Apr 05 06:33:21 2009 +0000 @@ -351,6 +351,8 @@ '_name' => 'Free', '_visible_name' => 'Free Account', '_key' => 'free_user', + '_account_type' => 'free', + '_account_default' => 1, # default account for payment system 'bookmark_max' => 25, 'checkfriends' => 0, 'checkfriends_interval' => 0, @@ -403,6 +405,7 @@ '_name' => 'Paid', '_key' => 'paid_user', # Some things expect that key name '_visible_name' => 'Paid Account', + '_account_type' => 'paid', 'bookmark_max' => 500, 'checkfriends' => 1, 'checkfriends_interval' => 600, @@ -453,6 +456,7 @@ '_name' => 'Premium Paid', '_key' => 'premium_user', '_visible_name' => 'Premium Paid Account', + '_account_type' => 'premium', 'bookmark_max' => 1000, 'checkfriends' => 1, 'checkfriends_interval' => 600, @@ -510,6 +514,7 @@ '_name' => 'Permanent', '_key' => 'permanent_user', '_visible_name' => 'Seed Account', + '_account_type' => 'seed', 'bookmark_max' => 1000, 'checkfriends' => 1, 'checkfriends_interval' => 600, diff -r 317e748df4b3 -r d6ec125e3d2b htdocs/shop.bml --- a/htdocs/shop.bml Sun Apr 05 03:53:44 2009 +0000 +++ b/htdocs/shop.bml Sun Apr 05 06:33:21 2009 +0000 @@ -22,31 +22,40 @@ body<= use vars qw/ %GET %POST $title /; # this page uses new style JS + LJ::need_res( 'stc/widget/shop.css' ); LJ::set_active_resource_group( 'jquery' ); - # translated/custom page title can go here - $title = "A title!"; - - # for pages that require authentication - my $remote = LJ::get_remote(); - return "<?needlogin?>" unless $remote; - - # allow the remote user to authenticate as another account (community, etc) - my $authas = $GET{authas} || $remote->user; - my $u = LJ::get_authas_user( $authas ); - return LJ::bad_input( $ML{'error.invalidauth'} ) - unless $u; - - my $ret; - - $ret .= "A template!"; - - return $ret; + # the basic shop page is a collection of widgets! thanks Janine :) + return DW::Widget::ShopCartStatusBar->render( %GET, minimal => 1 ); } _code?> + + +<?p Welcome to the Dreamwidth store! If you are interested in supporting Dreamwidth Studios +or are just looking for more features for your account, you have come to the right place. +I admit this page is pretty ugly and hope that someone will fix it. p?> + +<div id='left' class='shopbox'> + <?p If you are looking for a paid account, you pretty much have three options... p?> + <ul> + <li><a href='<?siteroot?>/shop/account?for=self'>...for yourself</a></li> + <li><a href='<?siteroot?>/shop/account?for=gift'>...for a gift</a></li> + <li><a href='<?siteroot?>/shop/account?for=new'>...a new account</a></li> + </ul> +</div> + +<div id='right' class='shopbox'> + <?p This box has some information about Dreamwidth, a promotional blurb or + some other thing to tell you about us. p?> + <?p There is likely going to be a really compelling bunch of text here, but darn + if someone else has to write it. (And English strip it.) p?> + <?p Well, please enjoy Dreamwidth! p?> +</div> + + + + + <=body -title=><?_code return $title; _code?> -head<= -<?_code return $headextra; _code?> -<=head +title=><?_ml .title _ml?> page?> diff -r 317e748df4b3 -r d6ec125e3d2b htdocs/shop.bml.text --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/htdocs/shop.bml.text Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,4 @@ +;; -*- coding: utf-8 -*- +.title=The Store + + diff -r 317e748df4b3 -r d6ec125e3d2b htdocs/shop/account.bml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/htdocs/shop/account.bml Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,149 @@ +<?_c +# +# shop.bml +# +# This is the main storefront for the shop. Gives people a page they can browse +# around looking for something interesting to buy. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# +_c?><?page +body<= +<?_code +{ + use strict; + use vars qw/ %GET %POST $title /; + + # this page uses new style JS + LJ::need_res( 'stc/widget/shop.css' ); + LJ::set_active_resource_group( 'jquery' ); + + # let's see what they're trying to do + my $for = $GET{for}; + return BML::redirect( "$LJ::SITEROOT/shop" ) + unless $for && $for =~ /^(?:self|gift|new)$/; + + # ensure they have a user if it's for self + my $remote = LJ::get_remote(); + return 'need a remote boss!' + if $for eq 'self' && ! $remote; + + # setup the output + my $ret = DW::Widget::ShopCartStatusBar->render( %GET ); + $ret .= qq{ +<div class="leftybox">Yep, this is the page where you buy a paid account. We could put some really awesome +text in this box to tell you what about paid accounts is awesome.</div> + }; + + # show account status box + $ret .= DW::Widget::PaidAccountStatus->render; + + # if they posted... + my $try_post = sub { + return 'Faiiiiiil' + unless LJ::check_form_auth(); + + my $at = $POST{accttype}; + return 'You must select an account type' + unless $at && exists $LJ::SHOP{$at}; + + # now try to add this item to their list + my $cart = DW::Shop->get->cart + or return 'Failed to get a shopping cart for you, please try again later.'; + + my %who_for; + if ( $for eq 'self' ) { + my $remote = LJ::get_remote() + or return '<?needlogin?>'; + $who_for{target_userid} = $remote->id; + + } elsif ( $for eq 'gift' ) { + # FIXME: try to validate the email address + $who_for{target_email} = $POST{str}; + + } elsif ( $for eq 'new' ) { + my $un = LJ::canonical_username( $POST{str} ); + return 'Invalid username' + unless $un; + return 'Username already in use' + if LJ::load_user( $un ); + + # FIXME: also, we should put a hold on this username to prevent people from + # doubling up on a purchase + $who_for{target_username} = $un; + + } + + # build a new item and try to toss it in the cart. this fails if there's a + # conflict or something + my ( $rv, $err ) = $cart->add_item( + DW::Shop::Item::Account->new( type => $at, %who_for ) + ); + return $err unless $rv; + + # to make this a gift for another account, simply change what target_userid + # is set to + + # to make this something to be emailed to someone, set target_email + + # to make this a purchase of a new account, set target_username + + # since we updated their list, return them to this page + return BML::redirect( "$LJ::SITEROOT/shop/account?for=$for" ); + }; + if ( LJ::did_post() ) { + my $errs = $try_post->(); + if ( $errs ) { + $ret .= qq{<div class="shop-error">$errs</div>}; + } + } + + # all done + return $ret; +} +_code?> + +<div style='clear: both;'></div> +<form method='post'> +<?_code return LJ::form_auth(); _code?> +<table class='shop-table'> +<tr><td> + +<strong>Premium Paid Account</strong><br /> +<input type='radio' name='accttype' id='prem6' value='prem6'><label for='prem6'>6 months for $20 USD</label></input><br /> +<input type='radio' name='accttype' id='prem12' value='prem12'><label for='prem12'>1 year for $40 USD</label></input> + +</td><td> + +<strong>Paid Account</strong><br /> +<input type='radio' name='accttype' id='paid1' value='paid1'><label for='paid1'>1 month for $3 USD</label></input><br /> +<input type='radio' name='accttype' id='paid2' value='paid2'><label for='paid2'>2 months for $5 USD</label></input><br /> +<input type='radio' name='accttype' id='paid6' value='paid6'><label for='paid6'>6 months for $13 USD</label></input><br /> +<input type='radio' name='accttype' id='paid12' value='paid12'><label for='paid12'>1 year for $25 USD</label></input> + +</td><td> + +<strong>Seed Account</strong><br /> +<input type='radio' name='accttype' id='seed' value='seed'><label for='seed'>Forever for $200 USD</label></input> + +</td></tr> +</table> + +username or email: <input type='text' name='str' /><br /> +<input type='submit' /><br /> + +<?p Dear Janine, please add the rest of the page here. p?> + + +</form> + +<=body +title=>Buy Paid Time +page?> diff -r 317e748df4b3 -r d6ec125e3d2b htdocs/shop/cart.bml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/htdocs/shop/cart.bml Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,64 @@ +<?_c +# +# shop/cart.bml +# +# Allows for viewing and manipulating the shopping cart. +# +# Authors: +# Mark Smith <mark@dreamwidth.org> +# +# Copyright (c) 2009 by Dreamwidth Studios, LLC. +# +# This program is free software; you may redistribute it and/or modify it under +# the same terms as Perl itself. For a copy of the license, please reference +# 'perldoc perlartistic' or 'perldoc perlgpl'. +# +_c?><?page +body<= +<?_code +{ + use strict; + use vars qw/ %GET %POST $title /; + + # this page uses new style JS + LJ::need_res( 'stc/widget/shop.css' ); + LJ::set_active_resource_group( 'jquery' ); + + # build a cart + my $cart = DW::Shop->get->cart + or return 'Failed to get a shopping cart for you, please try again later.'; + + # if they want us to remove... + my $cartid = $GET{cartid}+0; + my $itemid = $GET{itemid}+0; + my $action = $GET{action}; + + # remove the item then render the current cart + if ( $action eq 'remove' ) { + return 'Invalid cartid' + if $cart->id != $cartid; + return 'Failed to remove item' + unless $cart->remove_item( $itemid ); + } + + # setup the output + my $ret = DW::Widget::ShopCartStatusBar->render( %GET ); + + # now render the contents of the cart + $ret .= '<ul>'; + foreach my $item ( @{$cart->items} ) { + # FIXME: should require a POST to remove items + $ret .= '<li>[' . $item->id . ", <a href='$LJ::SITEROOT/shop/cart?cartid=" . $cart->id . "&itemid="; + $ret .= $item->id . "&action=remove'>remove</a>] "; + $ret .= $item->permanent ? '(permanent)' : ( '(' . $item->months . ' months)' ); + $ret .= ' ' . $item->class . ' account for ' . $item->t_html; + } + $ret .= '</ul>'; + + # all done + return $ret; +} +_code?> +<=body +title=>Your Shopping Cart +page?> diff -r 317e748df4b3 -r d6ec125e3d2b htdocs/stc/widgets/shop.css --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/htdocs/stc/widgets/shop.css Sun Apr 05 06:33:21 2009 +0000 @@ -0,0 +1,66 @@ +/* + stc/widgets/shop.css + + CSS classes for rendering the various shop widgets and components. + + Authors: + Mark Smith <mark@dreamwidth.org> + + Copyright (c) 2009 by Dreamwidth Studios, LLC. + + This program is free software; you may redistribute it and/or modify it under + the same terms as Perl itself. For a copy of the license, please reference + 'perldoc perlartistic' or 'perldoc perlgpl'. +*/ + + +.shop-browse-separator { + padding-top: 10px; +} + +.shopbox { + border: solid 1px red; + margin: 10px; + padding: 5px; + max-width: 35em; + min-height: 20em; +} + +.leftybox { + max-width: 35em; + float: left; + margin: 10px; +} + +#left { + float: left; +} + +#right { + float: right; +} + +.shop-account-status { + border: solid 1px red; + background-color: yellow; + float: right; + width: 30em; + padding: 5px; + margin: 10px; +} + +.shop-table { + margin: 1em auto; + min-width: 50em; +} + +.shop-table td { + vertical-align: top; +} + +.shop-error { + border: solid 1px red; + clear: both; + padding: 5px; + margin: 10px; +} --------------------------------------------------------------------------------
no subject
+ return $defaults[0];
Have I mentioned lately how much I appreciate your commenting style? It never fails to make me giggle!