lib/App/Web/Oof.pm

   1 package App::Web::Oof;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use utf8;
   7 use parent qw/Plack::Component/;
   8
   9 our $VERSION = '0.000_006';
  10
  11 use DBIx::Simple;
  12 use Email::Sender::Simple 'sendmail';
  13 use Email::Simple;
  14 use File::Slurp;
  15 use HTML::TreeBuilder;
  16 use HTML::Element::Library;
  17 use JSON::MaybeXS qw/encode_json decode_json/;
  18 use Plack::Builder;
  19 use Plack::Request;
  20 use Text::CSV;
  21 use Try::Tiny;
  22
  23 sub HTML::Element::iter3 {
  24         my ($self, $data, $code) = @_;
  25         my $orig = $self;
  26         my $prev = $orig;
  27         for my $el (@$data) {
  28                 my $current = $orig->clone;
  29                 $code->($el, $current);
  30                 $prev->postinsert($current);
  31                 $prev = $current;
  32         }
  33         $orig->detach;
  34 }
  35
  36 sub HTML::Element::fid    { shift->look_down(id    => shift) }
  37 sub HTML::Element::fclass { shift->look_down(class => qr/\b$_[0]\b/) }
  38
  39 ##################################################
  40
  41 my $postage_base = $ENV{OOF_POSTAGE_BASE} // 225;
  42 my $postage_per_item = $ENV{OOF_POSTAGE_PER_ITEM} // 50;
  43
  44 ##################################################
  45
  46 my %db;
  47 my ($form, $continue, $order, $details, $pay, $display);
  48
  49 {
  50         sub parse_html {
  51                 my $builder = HTML::TreeBuilder->new;
  52                 $builder->ignore_unknown(0);
  53                 $builder->parse_file("tmpl/$_[0].html");
  54                 $builder
  55         }
  56
  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';
  63 }
  64
  65 sub stringify_money { sprintf "£%.2f", $_[0] / 100 }
  66
  67 sub make_slug {
  68         my $slug = $_[0];
  69         $slug =~ y/ /-/;
  70         $slug =~ y/a-zA-Z0-9-//cd;
  71         $slug
  72 }
  73
  74 sub product_to_schemaorg {
  75         my ($include_url, %data) = @_;
  76         my $stock = $data{stock} > 0 ? 'InStock' : 'OutOfStock';
  77         +{
  78                 '@context' => 'http://schema.org/',
  79                 '@type'    => 'Product',
  80                 name => $data{title},
  81                 image => "/static/fullpics/$data{product}-1.jpg",
  82                 description => $data{subtitle},
  83                 offers => {
  84                         '@type' => 'Offer',
  85                         price => ($data{price} =~ s/(..)$/\.$1/r),
  86                         priceCurrency => 'GBP',
  87                         availability => "http://schema.org/$stock",
  88                         ($include_url ? (url => "/details/$data{product}/" . make_slug $data{title}) : ())
  89                 }
  90         }
  91 }
  92
  93 our %highlight;
  94 sub form_table_row {
  95         my ($data, $tr) = @_;
  96         $tr->attr(class => 'highlight') if $highlight{$data->{product}};
  97         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle stock/;
  98         $tr->fclass('price')->replace_content(stringify_money $data->{price});
  99         $tr->fclass('freepost')->detach unless $data->{freepost};
 100         $tr->fclass('title')->attr('data-product', $data->{product});
 101         $tr->fclass('title')->attr('href', '/details/'.$data->{product}.'/'.make_slug $data->{title});
 102 #       $tr->fclass('title')->attr('data-summary', $data->{summary});
 103         $tr->look_down(_tag => 'input')->attr(max => $data->{stock});
 104         $tr->look_down(_tag => 'input')->attr(name => 'quant'.$data->{product});
 105 }
 106
 107 sub form_app {
 108         my ($env) = @_;
 109         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 110         my $req = Plack::Request->new($env);
 111
 112         local %highlight = map { $_ => 1 } $req->param('highlight');
 113         my $data = $db{$$}->select(products => '*', {stock => {'>', 0}}, 'product')->hashes;
 114         my $tree = $form->clone;
 115         $tree->find('tbody')->find('tr')->iter3($data, \&form_table_row);
 116
 117         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 118 }
 119
 120 sub continue_table_row {
 121         my ($data, $tr) = @_;
 122         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle quantity/;
 123         $tr->fclass('freepost')->detach unless $data->{freepost};
 124         $tr->fclass('price')->replace_content(stringify_money $data->{subtotal});
 125         $tr->fclass('title')->attr('data-product', $data->{product});
 126 }
 127
 128 sub continue_app {
 129         my ($env) = @_;
 130         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 131         my $tree = $continue->clone;
 132         my $req = Plack::Request->new($env);
 133         my $params = $req->body_parameters;
 134
 135         my ($quant, $quant_freepost, $total, @data, @notes) = (0) x 3;
 136         for (sort keys %$params) {
 137                 next unless /^quant/;
 138                 next unless $params->{$_};
 139                 my $data = $db{$$}->select(products => '*', {product => substr $_, 5})->hash;
 140                 $data->{quantity} = $params->{$_};
 141                 if ($data->{stock} == 0) {
 142                         push @notes, 'Item is out of stock and was removed from order: '.$data->{title};
 143                         next
 144                 }
 145                 if ($data->{quantity} > $data->{stock}) {
 146                         $data->{quantity} = $data->{stock};
 147                         push @notes, 'Not enough units of "'.$data->{title}.'" available. Quantity reduced to '.$data->{quantity}
 148                 }
 149                 $data->{subtotal} = $data->{price} * $data->{quantity};
 150                 $quant += $data->{quantity};
 151                 $quant_freepost += $data->{quantity} if $data->{freepost};
 152                 $total += $data->{subtotal};
 153                 push @data, $data
 154         }
 155
 156         return [500, ['Content-type' => 'text/plain'], ['Error: no items in order.']] unless $quant;
 157
 158         $tree->fid('subtotal')->replace_content(stringify_money $total);
 159         my $dvalue;
 160         if ($params->{discount}) {
 161                 my $discount = $db{$$}->select(discounts => '*', {discount => $params->{discount}})->hash;
 162                 if (!defined $discount) {
 163                         push @notes, 'Discount code incorrect. No discount applied.'
 164                 } elsif ($db{$$}->select(orders => 'COUNT(*)', {discount => $params->{discount}})->list) {
 165                         push @notes, 'Discount code already used once. No discount applied.'
 166                 } else {
 167                         $dvalue = int (0.5 + $discount->{fraction} * $total) if $discount->{fraction};
 168                         $dvalue = $discount->{flat}                          if $discount->{flat};
 169                         $tree->fid('discount')->replace_content('-'.stringify_money $dvalue);
 170                         $total -= $dvalue;
 171                         $tree->look_down(name => 'discount')->attr(value => $params->{discount});
 172                         push @notes, 'Discount applied.'
 173                 }
 174         }
 175         $tree->look_down(name => 'discount')->detach unless $dvalue;
 176         $tree->fid('discount_tr')->detach unless $dvalue;
 177         my $postage = $postage_base + $postage_per_item * ($quant - $quant_freepost);
 178         $postage = 0 if $quant == $quant_freepost;
 179         $tree->fid('postage')->replace_content(stringify_money $postage);
 180         $total += $postage;
 181         $tree->fid('total')->replace_content(stringify_money $total);
 182
 183         $tree->fid('order')->find('tbody')->find('tr')->iter3(\@data, \&continue_table_row);
 184         $tree->iter($tree->fid('notes')->find('li') => @notes);
 185
 186         $tree->look_down(name => 'products')->attr(value => encode_json \@data);
 187         $tree->look_down(name => 'total')->attr(value => $total);
 188
 189         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 190 }
 191
 192 sub order_app {
 193         my ($env) = @_;
 194         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 195         my $tree = $order->clone;
 196         my $req = Plack::Request->new($env);
 197         my ($id) = $env->{PATH_INFO} =~ m,^/([0-9A-F]+),;
 198         if ($id) {
 199                 my $total = $db{$$}->select(orders => 'total', {id => $id})->list or
 200                   return [500, ['Content-type', 'text/plain'], ['Order not found']];
 201                 $tree->fid('orderid')->replace_content($id);
 202                 $tree->look_down(name => 'order')->attr(value => $id);
 203                 $tree->fid('total')->replace_content(stringify_money $total);
 204                 $tree->find('script')->attr('data-amount', $total);
 205                 return [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 206         } else {
 207                 my %parms = %{$req->body_parameters};
 208                 my $id = sprintf "%X%04X", time, $$;
 209                 my $err;
 210                 try {
 211                         $db{$$}->begin_work;
 212                         my $products = decode_json $req->body_parameters->{products};
 213                         for my $prod (@$products) {
 214                                 my $stock = $db{$$}->select(products => 'stock', {product => $prod->{product}})->list;
 215                                 die "Not enough of " .$prod->{title}."\n" if $prod->{quantity} > $stock;
 216                                 $db{$$}->update(products => {stock => $stock - $prod->{quantity}}, {product => $prod->{product}});
 217                         }
 218                         $db{$$}->insert(orders => {id => $id, date => time, %parms});
 219                         $db{$$}->commit;
 220                         sendmail (Email::Simple->create(
 221                                 header => [
 222                                         From    => $ENV{OOF_EMAIL_FROM},
 223                                         To      => $ENV{OOF_EMAIL_TO},
 224                                         Subject => "Order $id placed",
 225                                 ],
 226                                 body => 'A new order was placed.',
 227                         )) if $ENV{OOF_EMAIL_TO};
 228                 } catch {
 229                         $db{$$}->rollback;
 230                         $err = [500, ['Content-type', 'text/plain'], ["Error: $_"]]
 231                 };
 232                 return $err if $err;
 233                 return [303, [Location => "/order/$id"], []]
 234         }
 235 }
 236
 237 sub cancel {
 238         my ($order) = @_;
 239         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 240         $order = $db{$$}->select(orders => '*', {id => $order})->hash;
 241         my $products = decode_json $order->{products};
 242         $db{$$}->begin_work;
 243         try {
 244                 for my $prod (@$products) {
 245                         my $stock = $db{$$}->select(products => 'stock', {product => $prod->{product}})->list;
 246                         $db{$$}->update(products => {stock => $stock + $prod->{quantity}}, {product => $prod->{product}});
 247                 }
 248                 $db{$$}->delete(orders => {id => $order->{id}});
 249                 $db{$$}->commit;
 250         } catch {
 251                 $db{$$}->rollback;
 252                 die $_
 253         }
 254 }
 255
 256 sub details_list_element {
 257         my ($data, $li) = @_;
 258         $li->find('a')->attr(href => "/$data");
 259         my $thumb = $data =~ s/fullpics/thumbs/r;
 260         $thumb = $data unless -f $thumb;
 261         $li->find('img')->attr(src => "/$thumb");
 262 }
 263
 264 sub details_app {
 265         my ($env) = @_;
 266         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 267         my $tree = $details->clone;
 268         my ($id) = $env->{PATH_INFO} =~ m,^/(\d+),;
 269         my %data = %{$db{$$}->select(products => '*', {product => $id})->hash};
 270         my @pics = <static/fullpics/$id-*>;
 271         my $slug = make_slug $data{title};
 272         $tree->find('title')->replace_content("$data{title} | ledparts4you");
 273         $tree->find('h2')->replace_content($data{title});
 274         my $summary_literal = HTML::Element::Library::super_literal $data{summary};
 275         $tree->fid('summary')->replace_content($summary_literal);
 276         $tree->look_down(rel => 'canonical')->attr(href => "/details/$id/$slug");
 277         $tree->fid('pictures')->find('li')->iter3(\@pics, \&details_list_element);
 278         $tree->fid('jsonld')->replace_content(encode_json product_to_schemaorg '', %data);
 279
 280         for my $ahref ($tree->find('a')) {
 281                 $ahref->attr(href => "/form?highlight=$id") if $ahref->attr('href') eq '/';
 282         }
 283
 284         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 285 }
 286
 287 sub pay_app {
 288         my ($env) = @_;
 289         my $req = Plack::Request->new($env);
 290         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 291         my $order = $req->body_parameters->{order};
 292         my $token = $req->body_parameters->{stripeToken};
 293         return [500, ['Content-type' => 'text/html; charset=utf-8'], ['No token received, payment did not succeed.']] unless $token;
 294         $db{$$}->update(orders => {stripe_token => $token}, {id => $order});
 295         [200, ['Content-type' => 'text/html; charset=utf-8'], [$pay->as_HTML]];
 296 }
 297
 298 sub display_table_row {
 299         my ($data, $tr) = @_;
 300         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle quantity/;
 301         $tr->fclass('freepost')->detach unless $data->{freepost};
 302         $tr->fclass('price')->replace_content(stringify_money $data->{subtotal});
 303         $tr->fclass('title')->attr('data-product', $data->{product});
 304 }
 305
 306 sub display_order {
 307         my ($data, $div) = @_;
 308         my @products = @{decode_json $data->{products}};
 309         $div->find('table')->iter3(\@products, \&display_table_row);
 310         $div->fclass('name')->replace_content($data->{first_name} . ' ' . $data->{last_name});
 311         $div->fclass('stripe_token')->replace_content($data->{stripe_token}) if $data->{stripe_token};
 312 }
 313
 314 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";
 315
 316 sub make_hermes_csv {
 317         my ($order) = @_;
 318         my $csv = Text::CSV->new;
 319         my @fields = map { $order->{$_} } qw/address1 address2 address3 address4 postcode first_name last_name email/;
 320         $csv->combine(@fields, '', '', 'n', '', '', '', $order->{phone}, $order->{safe_place}, $order->{instructions});
 321         $csv->string
 322 }
 323
 324 sub display_app {
 325         my ($env) = @_;
 326         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 327         my $req = Plack::Request->new($env);
 328         my $n = int ($req->param('n') // 10);
 329         my @orders = $db{$$}->query("SELECT * FROM orders ORDER BY date DESC LIMIT $n")->hashes;
 330         my $tree = $display->clone;
 331         $tree->fclass('order')->iter3(\@orders, \&display_order);
 332         my $csv = join "\n", map { make_hermes_csv $_ } @orders;
 333         $tree->fid('hermes_csv')->replace_content($csv_header . $csv);
 334         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]];
 335 }
 336
 337 sub app {
 338         my $footer = read_file 'tmpl/footer.html';
 339         builder {
 340                 enable sub {
 341                         my $app = shift;
 342                         sub {
 343                                 my $res = $app->(@_);
 344                                 $res->[2][0] =~ s,</body>,$footer</body>, if $res->[0] == 200;
 345                                 $res;
 346                         }
 347                 };
 348                 mount '/' => sub { [301, [Location => '/form'], []] };
 349                 mount '/form'     => \&form_app;
 350                 mount '/continue' => \&continue_app;
 351                 mount '/order'    => \&order_app;
 352                 mount '/details'  => \&details_app;
 353                 mount '/pay'      => \&pay_app;
 354                 mount '/display'  => \&display_app;
 355         }
 356 }
 357
 358 1;
 359 __END__
 360
 361 =head1 NAME
 362
 363 App::Web::Oof - Oversimplified order form / ecommerce website
 364
 365 =head1 SYNOPSIS
 366
 367   use App::Web::Oof;
 368
 369 =head1 DESCRIPTION
 370
 371 Oof (Oversimplified order form) is a very simple ecommerce website.
 372 It is the code behind L<https://ledparts4you.uk.to>.
 373
 374 This version is reasonably functional, yet not very reusable, hence
 375 the version number.
 376
 377 =head1 AUTHOR
 378
 379 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 380
 381 =head1 COPYRIGHT AND LICENSE
 382
 383 Copyright (C) 2016 by Marius Gavrilescu
 384
 385 This library is free software; you can redistribute it and/or modify
 386 it under the same terms as Perl itself, either Perl version 5.22.1 or,
 387 at your option, any later version of Perl 5 you may have available.
 388
 389
 390 =cut