7 use parent qw
/Plack::Component/;
9 our $VERSION = '0.000_007';
12 use Email
::Sender
::Simple
'sendmail';
15 use HTML
::TreeBuilder
;
16 use HTML
::Element
::Library
;
17 use JSON
::MaybeXS qw
/encode_json decode_json/;
23 sub HTML
::Element
::iter3
{
24 my ($self, $data, $code) = @_;
28 my $current = $orig->clone;
29 $code->($el, $current);
30 $prev->postinsert($current);
36 sub HTML
::Element
::fid
{ shift->look_down(id
=> shift) }
37 sub HTML
::Element
::fclass
{ shift->look_down(class => qr/\b$_[0]\b/) }
39 ##################################################
41 my $postage_base = $ENV{OOF_POSTAGE_BASE
} // 225;
42 my $postage_per_item = $ENV{OOF_POSTAGE_PER_ITEM
} // 50;
44 ##################################################
47 my ($form, $continue, $order, $details, $pay, $display);
51 my $builder = HTML
::TreeBuilder
->new;
52 $builder->ignore_unknown(0);
53 $builder->parse_file("tmpl/$_[0].html");
57 $form = parse_html
'form';
58 $continue = parse_html
'continue';
59 $order = parse_html
'order';
60 $details = parse_html
'details';
61 $pay = parse_html
'pay';
62 $display = parse_html
'display';
65 sub stringify_money
{ sprintf "£%.2f", $_[0] / 100 }
70 $slug =~ y/a-zA-Z0-9-//cd;
74 sub product_to_schemaorg
{
75 my ($include_url, %data) = @_;
76 my $stock = $data{stock
} > 0 ?
'InStock' : 'OutOfStock';
78 push @extra, (brand
=> {'@type' => 'Brand', name
=> $data{brand
}}) if $data{brand
};
79 push @extra, (model
=> $data{model
}) if $data{model
};
81 '@context' => 'http://schema.org/',
84 image
=> "/static/fullpics/$data{product}-1.jpg",
85 description
=> $data{subtitle
},
89 price
=> ($data{price
} =~ s/(..)$/\.$1/r),
90 priceCurrency
=> 'GBP',
91 availability
=> "http://schema.org/$stock",
92 ($include_url ?
(url
=> "/details/$data{product}/" . make_slug
$data{title
}) : ())
100 $tr->attr(class => 'highlight') if $highlight{$data->{product
}};
101 $tr->fclass($_)->replace_content($data->{$_}) for qw
/title subtitle stock/;
102 $tr->fclass('price')->replace_content(stringify_money
$data->{price
});
103 $tr->fclass('freepost')->detach unless $data->{freepost
};
104 $tr->fclass('title')->attr('data-product', $data->{product
});
105 $tr->fclass('title')->attr('href', '/details/'.$data->{product
}.'/'.make_slug
$data->{title
});
106 # $tr->fclass('title')->attr('data-summary', $data->{summary});
107 $tr->look_down(_tag
=> 'input')->attr(max
=> $data->{stock
});
108 $tr->look_down(_tag
=> 'input')->attr(name
=> 'quant'.$data->{product
});
113 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
114 my $req = Plack
::Request
->new($env);
116 local %highlight = map { $_ => 1 } $req->param('highlight');
117 my $data = $db{$$}->select(products
=> '*', {stock
=> {'>', 0}}, 'product')->hashes;
118 my $tree = $form->clone;
119 $tree->find('tbody')->find('tr')->iter3($data, \
&form_table_row
);
121 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
124 sub continue_table_row
{
125 my ($data, $tr) = @_;
126 $tr->fclass($_)->replace_content($data->{$_}) for qw
/title subtitle quantity/;
127 $tr->fclass('freepost')->detach unless $data->{freepost
};
128 $tr->fclass('price')->replace_content(stringify_money
$data->{subtotal
});
129 $tr->fclass('title')->attr('data-product', $data->{product
});
134 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
135 my $tree = $continue->clone;
136 my $req = Plack
::Request
->new($env);
137 my $params = $req->body_parameters;
139 my ($quant, $quant_freepost, $total, @data, @notes) = (0) x
3;
140 for (sort keys %$params) {
141 next unless /^quant/;
142 next unless $params->{$_};
143 my $data = $db{$$}->select(products
=> '*', {product
=> substr $_, 5})->hash;
144 $data->{quantity
} = $params->{$_};
145 if ($data->{stock
} == 0) {
146 push @notes, 'Item is out of stock and was removed from order: '.$data->{title
};
149 if ($data->{quantity
} > $data->{stock
}) {
150 $data->{quantity
} = $data->{stock
};
151 push @notes, 'Not enough units of "'.$data->{title
}.'" available. Quantity reduced to '.$data->{quantity
}
153 $data->{subtotal
} = $data->{price
} * $data->{quantity
};
154 $quant += $data->{quantity
};
155 $quant_freepost += $data->{quantity
} if $data->{freepost
};
156 $total += $data->{subtotal
};
160 return [500, ['Content-type' => 'text/plain'], ['Error: no items in order.']] unless $quant;
162 $tree->fid('subtotal')->replace_content(stringify_money
$total);
164 if ($params->{discount
}) {
165 my $discount = $db{$$}->select(discounts
=> '*', {discount
=> $params->{discount
}})->hash;
166 if (!defined $discount) {
167 push @notes, 'Discount code incorrect. No discount applied.'
168 } elsif ($db{$$}->select(orders
=> 'COUNT(*)', {discount
=> $params->{discount
}})->list) {
169 push @notes, 'Discount code already used once. No discount applied.'
171 $dvalue = int (0.5 + $discount->{fraction
} * $total) if $discount->{fraction
};
172 $dvalue = $discount->{flat
} if $discount->{flat
};
173 $tree->fid('discount')->replace_content('-'.stringify_money
$dvalue);
175 $tree->look_down(name
=> 'discount')->attr(value
=> $params->{discount
});
176 push @notes, 'Discount applied.'
179 $tree->look_down(name
=> 'discount')->detach unless $dvalue;
180 $tree->fid('discount_tr')->detach unless $dvalue;
181 my $postage = $postage_base + $postage_per_item * ($quant - $quant_freepost);
182 $postage = 0 if $quant == $quant_freepost;
183 $tree->fid('postage')->replace_content(stringify_money
$postage);
185 $tree->fid('total')->replace_content(stringify_money
$total);
187 $tree->fid('order')->find('tbody')->find('tr')->iter3(\
@data, \
&continue_table_row
);
188 $tree->iter($tree->fid('notes')->find('li') => @notes);
190 $tree->look_down(name
=> 'products')->attr(value
=> encode_json \
@data);
191 $tree->look_down(name
=> 'total')->attr(value
=> $total);
193 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
198 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
199 my $tree = $order->clone;
200 my $req = Plack
::Request
->new($env);
201 my ($id) = $env->{PATH_INFO
} =~ m
,^/([0-9A
-F
]+),;
203 my $total = $db{$$}->select(orders
=> 'total', {id
=> $id})->list or
204 return [500, ['Content-type', 'text/plain'], ['Order not found']];
205 $tree->fid('orderid')->replace_content($id);
206 $tree->look_down(name
=> 'order')->attr(value
=> $id);
207 $tree->fid('total')->replace_content(stringify_money
$total);
208 $tree->find('script')->attr('data-amount', $total);
209 return [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
211 my %parms = %{$req->body_parameters};
212 my $id = sprintf "%X%04X", time, $$;
216 my $products = decode_json
$req->body_parameters->{products
};
217 for my $prod (@
$products) {
218 my $stock = $db{$$}->select(products
=> 'stock', {product
=> $prod->{product
}})->list;
219 die "Not enough of " .$prod->{title
}."\n" if $prod->{quantity
} > $stock;
220 $db{$$}->update(products
=> {stock
=> $stock - $prod->{quantity
}}, {product
=> $prod->{product
}});
222 $db{$$}->insert(orders
=> {id
=> $id, date
=> time, %parms});
224 sendmail
(Email
::Simple
->create(
226 From
=> $ENV{OOF_EMAIL_FROM
},
227 To
=> $ENV{OOF_EMAIL_TO
},
228 Subject
=> "Order $id placed",
230 body
=> 'A new order was placed.',
231 )) if $ENV{OOF_EMAIL_TO
};
234 $err = [500, ['Content-type', 'text/plain'], ["Error: $_"]]
237 return [303, [Location
=> "/order/$id"], []]
243 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
244 $order = $db{$$}->select(orders
=> '*', {id
=> $order})->hash;
245 my $products = decode_json
$order->{products
};
248 for my $prod (@
$products) {
249 my $stock = $db{$$}->select(products
=> 'stock', {product
=> $prod->{product
}})->list;
250 $db{$$}->update(products
=> {stock
=> $stock + $prod->{quantity
}}, {product
=> $prod->{product
}});
252 $db{$$}->delete(orders
=> {id
=> $order->{id
}});
260 sub details_list_element
{
261 my ($data, $li) = @_;
262 $li->find('a')->attr(href
=> "/$data");
263 my $thumb = $data =~ s/fullpics/thumbs/r;
264 $thumb = $data unless -f
$thumb;
265 $li->find('img')->attr(src
=> "/$thumb");
270 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
271 my $tree = $details->clone;
272 my ($id) = $env->{PATH_INFO
} =~ m
,^/(\d
+),;
273 my %data = %{$db{$$}->select(products
=> '*', {product
=> $id})->hash};
274 my @pics = <static
/fullpics/$id-*>;
275 my $slug = make_slug
$data{title
};
276 $tree->find('title')->replace_content("$data{title} | ledparts4you");
277 $tree->find('h2')->replace_content($data{title
});
278 my $summary_literal = HTML
::Element
::Library
::super_literal
$data{summary
};
279 $tree->fid('summary')->replace_content($summary_literal);
280 $tree->look_down(rel
=> 'canonical')->attr(href
=> "/details/$id/$slug");
281 $tree->fid('pictures')->find('li')->iter3(\
@pics, \
&details_list_element
);
282 $tree->fid('jsonld')->replace_content(encode_json product_to_schemaorg
'', %data);
284 for my $ahref ($tree->find('a')) {
285 $ahref->attr(href
=> "/form?highlight=$id") if $ahref->attr('href') eq '/';
288 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
293 my $req = Plack
::Request
->new($env);
294 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
295 my $order = $req->body_parameters->{order
};
296 my $token = $req->body_parameters->{stripeToken
};
297 return [500, ['Content-type' => 'text/html; charset=utf-8'], ['No token received, payment did not succeed.']] unless $token;
298 $db{$$}->update(orders
=> {stripe_token
=> $token}, {id
=> $order});
299 [200, ['Content-type' => 'text/html; charset=utf-8'], [$pay->as_HTML]];
302 sub display_table_row
{
303 my ($data, $tr) = @_;
304 $tr->fclass($_)->replace_content($data->{$_}) for qw
/title subtitle quantity/;
305 $tr->fclass('freepost')->detach unless $data->{freepost
};
306 $tr->fclass('price')->replace_content(stringify_money
$data->{subtotal
});
307 $tr->fclass('title')->attr('data-product', $data->{product
});
311 my ($data, $div) = @_;
312 my @products = @
{decode_json
$data->{products
}};
313 $div->find('table')->iter3(\
@products, \
&display_table_row
);
314 $div->fclass('name')->replace_content($data->{first_name
} . ' ' . $data->{last_name
});
315 $div->fclass('stripe_token')->replace_content($data->{stripe_token
}) if $data->{stripe_token
};
318 my $csv_header = 'Address_line_1,Address_line_2,Address_line_3,Address_line_4,Postcode,First_name,Last_name,Email,Weight(Kg),Compensation(�),Signature(y/n),Reference,Contents,Parcel_value(�),Delivery_phone,Delivery_safe_place,Delivery_instructions' . "\n";
320 sub make_hermes_csv
{
322 my $csv = Text
::CSV
->new;
323 my @fields = map { $order->{$_} } qw
/address1 address2 address3 address4 postcode first_name last_name email/;
324 $csv->combine(@fields, '', '', 'n', '', '', '', $order->{phone
}, $order->{safe_place
}, $order->{instructions
});
330 $db{$$} //= DBIx
::Simple
->connect($ENV{OOF_DSN
} // 'dbi:Pg:');
331 my $req = Plack
::Request
->new($env);
332 my $n = int ($req->param('n') // 10);
333 my @orders = $db{$$}->query("SELECT * FROM orders ORDER BY date DESC LIMIT $n")->hashes;
334 my $tree = $display->clone;
335 $tree->fclass('order')->iter3(\
@orders, \
&display_order
);
336 my $csv = join "\n", map { make_hermes_csv
$_ } @orders;
337 $tree->fid('hermes_csv')->replace_content($csv_header . $csv);
338 [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]];
342 my $footer = read_file
'tmpl/footer.html';
347 my $res = $app->(@_);
348 $res->[2][0] =~ s
,</body>,$footer</body
>, if $res->[0] == 200;
352 mount
'/' => sub { [301, [Location
=> '/form'], []] };
353 mount
'/form' => \
&form_app
;
354 mount
'/continue' => \
&continue_app
;
355 mount
'/order' => \
&order_app
;
356 mount
'/details' => \
&details_app
;
357 mount
'/pay' => \
&pay_app
;
358 mount
'/display' => \
&display_app
;
367 App::Web::Oof - Oversimplified order form / ecommerce website
375 Oof (Oversimplified order form) is a very simple ecommerce website.
376 It is the code behind L<https://ledparts4you.uk.to>.
378 This version is reasonably functional, yet not very reusable, hence
383 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
385 =head1 COPYRIGHT AND LICENSE
387 Copyright (C) 2016 by Marius Gavrilescu
389 This library is free software; you can redistribute it and/or modify
390 it under the same terms as Perl itself, either Perl version 5.22.1 or,
391 at your option, any later version of Perl 5 you may have available.