]>
iEval git - app-web-oof.git/blob - lib/App/Web/Oof.pm
7 use parent qw
/Plack::Component/;
9 our $VERSION = '0.000_005';
13 use HTML
::TreeBuilder
;
14 use HTML
::Element
::Library
;
15 use JSON
::MaybeXS qw
/encode_json decode_json/;
20 sub HTML
::Element
::iter3
{
21 my ($self, $data, $code) = @_;
25 my $current = $orig->clone;
26 $code->($el, $current);
27 $prev->postinsert($current);
33 sub HTML
::Element
::fid
{ shift->look_down(id
=> shift) }
34 sub HTML
::Element
::fclass
{ shift->look_down(class => qr/\b$_[0]\b/) }
36 ##################################################
39 my ($form, $continue, $order, $details, $pay);
43 my $builder = HTML
::TreeBuilder
->new;
44 $builder->ignore_unknown(0);
45 $builder->parse_file("tmpl/$_[0].html");
49 $form = parse_html
'form';
50 $continue = parse_html
'continue';
51 $order = parse_html
'order';
52 $details = parse_html
'details';
53 $pay = parse_html
'pay';
56 sub stringify_money
{ sprintf "£%.2f", $_[0] / 100 }
61 $slug =~ y/a-zA-Z0-9-//cd;
68 $tr->attr(class => 'highlight') if $highlight{$data->{product
}};
69 $tr->fclass($_)->replace_content($data->{$_}) for qw
/title subtitle stock/;
70 $tr->fclass('price')->replace_content(stringify_money
$data->{price
});
71 $tr->fclass('freepost')->detach unless $data->{freepost
};
72 $tr->fclass('title')->attr('data-product', $data->{product
});
73 $tr->fclass('title')->attr('href', '/details/'.$data->{product
}.'/'.make_slug
$data->{title
});
74 # $tr->fclass('title')->attr('data-summary', $data->{summary});
75 $tr->look_down(_tag
=> 'input')->attr(max
=> $data->{stock
});
76 $tr->look_down(_tag
=> 'input')->attr(name
=> 'quant'.$data->{product
});
81 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
82 my $req = Plack
::Request
->new($env);
84 local %highlight = map { $_ => 1 } $req->param('highlight');
85 my $data = $db{$$}->select(products
=> '*', {}, 'product')->hashes;
86 my $tree = $form->clone;
87 $tree->find('tbody')->find('tr')->iter3($data, \
&form_table_row
);
89 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
92 sub continue_table_row
{
94 $tr->fclass($_)->replace_content($data->{$_}) for qw
/title subtitle quantity/;
95 $tr->fclass('freepost')->detach unless $data->{freepost
};
96 $tr->fclass('price')->replace_content(stringify_money
$data->{subtotal
});
97 $tr->fclass('title')->attr('data-product', $data->{product
});
102 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
103 my $tree = $continue->clone;
104 my $req = Plack
::Request
->new($env);
105 my $params = $req->body_parameters;
107 my ($quant, $quant_freepost, $total, @data, @notes) = (0) x
3;
108 for (sort keys %$params) {
109 next unless /^quant/;
110 next unless $params->{$_};
111 my $data = $db{$$}->select(products
=> '*', {product
=> substr $_, 5})->hash;
112 $data->{quantity
} = $params->{$_};
113 if ($data->{stock
} == 0) {
114 push @notes, 'Item is out of stock and was removed from order: '.$data->{title
};
117 if ($data->{quantity
} > $data->{stock
}) {
118 $data->{quantity
} = $data->{stock
};
119 push @notes, 'Not enough units of "'.$data->{title
}.'" available. Quantity reduced to '.$data->{quantity
}
121 $data->{subtotal
} = $data->{price
} * $data->{quantity
};
122 $quant += $data->{quantity
};
123 $quant_freepost += $data->{quantity
} if $data->{freepost
};
124 $total += $data->{subtotal
};
128 return [500, ['Content-type' => 'text/plain'], ['Error: no items in order.']] unless $quant;
130 $tree->fid('subtotal')->replace_content(stringify_money
$total);
132 if ($params->{discount
}) {
133 my $discount = $db{$$}->select(discounts
=> '*', {discount
=> $params->{discount
}})->hash;
134 if (!defined $discount) {
135 push @notes, 'Discount code incorrect. No discount applied.'
136 } elsif ($db{$$}->select(orders
=> 'COUNT(*)', {discount
=> $params->{discount
}})->list) {
137 push @notes, 'Discount code already used once. No discount applied.'
139 $dvalue = int (0.5 + $discount->{fraction
} * $total) if $discount->{fraction
};
140 $dvalue = $discount->{flat
} if $discount->{flat
};
141 $tree->fid('discount')->replace_content('-'.stringify_money
$dvalue);
143 $tree->look_down(name
=> 'discount')->attr(value
=> $params->{discount
});
144 push @notes, 'Discount applied.'
147 $tree->look_down(name
=> 'discount')->detach unless $dvalue;
148 $tree->fid('discount_tr')->detach unless $dvalue;
149 my $postage = 220 + 50 * ($quant - $quant_freepost);
150 $postage = 0 if $quant == $quant_freepost;
151 $tree->fid('postage')->replace_content(stringify_money
$postage);
153 $tree->fid('total')->replace_content(stringify_money
$total);
155 $tree->fid('order')->find('tbody')->find('tr')->iter3(\
@data, \
&continue_table_row
);
156 $tree->iter($tree->fid('notes')->find('li') => @notes);
158 $tree->look_down(name
=> 'products')->attr(value
=> encode_json \
@data);
159 $tree->look_down(name
=> 'total')->attr(value
=> $total);
161 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
166 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
167 my $tree = $order->clone;
168 my $req = Plack
::Request
->new($env);
169 my ($id) = $env->{PATH_INFO
} =~ m
,^/([0-9A
-F
]+),;
171 my $total = $db{$$}->select(orders
=> 'total', {id
=> $id})->list or
172 return [500, ['Content-type', 'text/plain'], ['Order not found']];
173 $tree->fid('orderid')->replace_content($id);
174 $tree->look_down(name
=> 'order')->attr(value
=> $id);
175 $tree->fid('total')->replace_content(stringify_money
$total);
176 $tree->find('script')->attr('data-amount', $total);
177 return [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
179 my %parms = %{$req->body_parameters};
180 my $id = sprintf "%X%04X", time, $$;
184 my $products = decode_json
$req->body_parameters->{products
};
185 for my $prod (@
$products) {
186 my $stock = $db{$$}->select(products
=> 'stock', {product
=> $prod->{product
}})->list;
187 die "Not enough of " .$prod->{title
}."\n" if $prod->{quantity
} > $stock;
188 $db{$$}->update(products
=> {stock
=> $stock - $prod->{quantity
}}, {product
=> $prod->{product
}});
190 $db{$$}->insert(orders
=> {id
=> $id, %parms});
194 $err = [500, ['Content-type', 'text/plain'], ["Error: $_"]]
197 return [303, [Location
=> "/order/$id"], []]
203 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
204 $order = $db{$$}->select(orders
=> '*', {id
=> $order})->hash;
205 my $products = decode_json
$order->{products
};
208 for my $prod (@
$products) {
209 my $stock = $db{$$}->select(products
=> 'stock', {product
=> $prod->{product
}})->list;
210 $db{$$}->update(products
=> {stock
=> $stock + $prod->{quantity
}}, {product
=> $prod->{product
}});
212 $db{$$}->delete(orders
=> {id
=> $order->{id
}});
220 sub details_list_element
{
221 my ($data, $li) = @_;
222 $li->find('a')->attr(href
=> "/$data");
223 my $thumb = $data =~ s/fullpics/thumbs/r;
224 $thumb = $data unless -f
$thumb;
225 $li->find('img')->attr(src
=> "/$thumb");
230 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
231 my $tree = $details->clone;
232 my ($id) = $env->{PATH_INFO
} =~ m
,^/(\d
+),;
233 my ($title, $summary) = $db{$$}->select(products
=> [qw
/title summary/], {product
=> $id})->list;
234 my @pics = <static
/fullpics/$id-*>;
235 my $slug = make_slug
$title;
236 $tree->find('title')->replace_content("Pictures of $title | ledparts4you");
237 $tree->find('h2')->replace_content($title);
238 $tree->fid('summary')->replace_content($summary);
239 $tree->look_down(rel
=> 'canonical')->attr(href
=> "/details/$id/$slug");
240 $tree->fid('pictures')->find('li')->iter3(\
@pics, \
&details_list_element
);
242 for my $ahref ($tree->find('a')) {
243 $ahref->attr(href
=> "/form?highlight=$id") if $ahref->attr('href') eq '/';
246 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
251 my $req = Plack
::Request
->new($env);
252 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
253 my $order = $req->body_parameters->{order
};
254 my $token = $req->body_parameters->{stripeToken
};
255 return [500, ['Content-type' => 'text/html; charset=utf-8'], ['No token received, payment did not succeed.']] unless $token;
256 $db{$$}->update(orders
=> {stripe_token
=> $token}, {id
=> $order});
257 [200, ['Content-type' => 'text/html; charset=utf-8'], [$pay->as_HTML]];
261 my $footer = read_file
'tmpl/footer.html';
266 my $res = $app->(@_);
267 $res->[2][0] =~ s
,</body>,$footer</body
>, if $res->[0] == 200;
271 mount
'/' => sub { [301, [Location
=> '/form'], []] };
272 mount
'/form' => \
&form_app
;
273 mount
'/continue' => \
&continue_app
;
274 mount
'/order' => \
&order_app
;
275 mount
'/details' => \
&details_app
;
276 mount
'/pay' => \
&pay_app
;
285 App::Web::Oof - Oversimplified order form / ecommerce website
293 Oof (Oversimplified order form) is a very simple ecommerce website.
294 It is the code behind L<https://ledparts4you.uk.to>.
296 This version is reasonably functional, yet not very reusable, hence
301 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
303 =head1 COPYRIGHT AND LICENSE
305 Copyright (C) 2016 by Marius Gavrilescu
307 This library is free software; you can redistribute it and/or modify
308 it under the same terms as Perl itself, either Perl version 5.22.1 or,
309 at your option, any later version of Perl 5 you may have available.
This page took 0.080958 seconds and 4 git commands to generate.