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_001';
  10
  11 use DBIx::Simple;
  12 use HTML::TreeBuilder;
  13 use HTML::Element::Library;
  14 use JSON::MaybeXS qw/encode_json decode_json/;
  15 use Plack::Builder;
  16 use Plack::Request;
  17
  18 sub HTML::Element::iter3 {
  19         my ($self, $data, $code) = @_;
  20         my $orig = $self;
  21         my $prev = $orig;
  22         for my $el (@$data) {
  23                 my $current = $orig->clone;
  24                 $code->($el, $current);
  25                 $prev->postinsert($current);
  26                 $prev = $current;
  27         }
  28         $orig->detach;
  29 }
  30
  31 sub HTML::Element::fid    { shift->look_down(id    => shift) }
  32 sub HTML::Element::fclass { shift->look_down(class => qr/\b$_[0]\b/) }
  33
  34 ##################################################
  35
  36 my $db;
  37 my ($form, $continue, $order);
  38
  39 {
  40         sub parse_html {
  41                 my $builder = HTML::TreeBuilder->new;
  42                 $builder->ignore_unknown(0);
  43                 $builder->parse_file("tmpl/$_[0].html");
  44                 $builder
  45         }
  46
  47         $form     = parse_html 'form';
  48         $continue = parse_html 'continue';
  49         $order    = parse_html 'order';
  50 }
  51
  52 sub stringify_money { sprintf "£%.2f", $_[0] / 100 }
  53
  54 sub form_table_row {
  55         my ($data, $tr) = @_;
  56         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle stock/;
  57         $tr->fclass('price')->replace_content(stringify_money $data->{price});
  58         $tr->fclass('title')->attr('data-product', $data->{product});
  59         $tr->fclass('title')->attr('data-summary', $data->{summary});
  60         $tr->look_down(_tag => 'input')->attr(max => $data->{stock});
  61         $tr->look_down(_tag => 'input')->attr(name => 'quant'.$data->{product});
  62 }
  63
  64 sub form_app {
  65         my ($env) = @_;
  66         $db //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
  67
  68         my $data = $db->select(products => '*', {}, 'product')->hashes;
  69         my $tree = $form->clone;
  70         $tree->find('tbody')->find('tr')->iter3($data, \&form_table_row);
  71
  72         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
  73 }
  74
  75 sub continue_table_row {
  76         my ($data, $tr) = @_;
  77         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle quantity/;
  78         $tr->fclass('price')->replace_content(stringify_money $data->{subtotal});
  79         $tr->fclass('title')->attr('data-product', $data->{product});
  80 }
  81
  82 sub continue_app {
  83         my ($env) = @_;
  84         $db //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
  85         my $tree = $continue->clone;
  86         my $req = Plack::Request->new($env);
  87         my $params = $req->body_parameters;
  88
  89         my ($quant, $total, @data, @notes);
  90         for (sort keys %$params) {
  91                 next unless /^quant/;
  92                 next unless $params->{$_};
  93                 my $data = $db->select(products => '*', {product => substr $_, 5})->hash;
  94                 $data->{quantity} = $params->{$_};
  95                 if ($data->{stock} == 0) {
  96                         push @notes, 'Item is out of stock and was removed from order: '.$data->{title};
  97                         next
  98                 }
  99                 if ($data->{quantity} > $data->{stock}) {
 100                         $data->{quantity} = $data->{stock};
 101                         push @notes, 'Not enough units of "'.$data->{title}.'" available. Quantity reduced to '.$data->{quantity}
 102                 }
 103                 $data->{subtotal} = $data->{price} * $data->{quantity};
 104                 $quant += $data->{quantity};
 105                 $total += $data->{subtotal};
 106                 push @data, $data
 107         }
 108
 109         $tree->fid('subtotal')->replace_content(stringify_money $total);
 110         my $dvalue;
 111         if ($params->{discount}) {
 112                 my $discount = $db->select(discounts => '*', {discount => $params->{discount}})->hash;
 113                 if (!defined $discount) {
 114                         push @notes, 'Discount code incorrect. No discount applied.'
 115                 } elsif ($db->select(orders => 'COUNT(*)', {discount => $params->{discount}})->list) {
 116                         push @notes, 'Discount code already used once. No discount applied.'
 117                 } else {
 118                         $dvalue = int (0.5 + $discount->{fraction} * $total) if $discount->{fraction};
 119                         $dvalue = $discount->{flat}                          if $discount->{flat};
 120                         $tree->fid('discount')->replace_content('-'.stringify_money $dvalue);
 121                         $total -= $dvalue;
 122                         $tree->look_down(name => 'discount')->attr(value => $params->{discount});
 123                         push @notes, 'Discount applied.'
 124                 }
 125         }
 126         $tree->look_down(name => 'discount')->detach unless $dvalue;
 127         $tree->fid('discount_tr')->detach unless $dvalue;
 128         my $postage = 220 + 50 * $quant;
 129         $tree->fid('postage')->replace_content(stringify_money $postage);
 130         $total += $postage;
 131         $tree->fid('total')->replace_content(stringify_money $total);
 132
 133         $tree->fid('order')->find('tbody')->find('tr')->iter3(\@data, \&continue_table_row);
 134         $tree->iter($tree->fid('notes')->find('li') => @notes);
 135
 136         $tree->look_down(name => 'products')->attr(value => encode_json \@data);
 137         $tree->look_down(name => 'total')->attr(value => $total);
 138
 139         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 140 }
 141
 142 sub order_app {
 143         my ($env) = @_;
 144         $db //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 145         my $tree = $order->clone;
 146         my $req = Plack::Request->new($env);
 147         my $id = sprintf "%X", time; # Not good enough!
 148
 149         $db->begin_work;
 150         $db->insert(orders => {id => $id, %{$req->body_parameters}});
 151         my $products = decode_json $req->body_parameters->{products};
 152         for my $prod (@$products) {
 153                 my $stock = $db->select(products => 'stock', {product => $prod->{product}})->list;
 154                 die "Not enough of " .$prod->{title}."\n" if $prod->{quantity} > $stock;
 155                 $db->update(products => {stock => $stock - $prod->{quantity}}, {product => $prod->{product}});
 156         }
 157         $db->commit;
 158
 159         $tree->fid('orderid')->replace_content($id);
 160         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 161 }
 162
 163 sub app {
 164         builder {
 165                 mount '/' => sub { [301, [Location => '/form'], []] };
 166                 mount '/form'     => \&form_app;
 167                 mount '/continue' => \&continue_app;
 168                 mount '/order'    => \&order_app;
 169         }
 170 }
 171
 172 1;
 173 __END__
 174
 175 =head1 NAME
 176
 177 App::Web::Oof - Oversimplified order form / ecommerce website
 178
 179 =head1 SYNOPSIS
 180
 181   use App::Web::Oof;
 182
 183 =head1 DESCRIPTION
 184
 185 Oof (Oversimplified order form) is a very simple ecommerce website.
 186 As of this moment it is incomplete (although functional), hence the
 187 version number.
 188
 189 =head1 AUTHOR
 190
 191 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 192
 193 =head1 COPYRIGHT AND LICENSE
 194
 195 Copyright (C) 2016 by Marius Gavrilescu
 196
 197 This library is free software; you can redistribute it and/or modify
 198 it under the same terms as Perl itself, either Perl version 5.22.1 or,
 199 at your option, any later version of Perl 5 you may have available.
 200
 201
 202 =cut