Haskell Relational Records (HRR) - initial sprint

RelationalRecord/.gitignore

@@ -0,0 +1 @@
+*.db

RelationalRecord/ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for RelationalRecord
+
+## 0.1.0.0  -- 2016-11-04
+
+* Project start.

RelationalRecord/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2016 VacationLabs
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

RelationalRecord/RelationalRecord.cabal

@@ -0,0 +1,61 @@
+name:                RelationalRecord
+version:             0.1.0.0
+synopsis:
+-- description:
+license:             MIT
+license-file:        LICENSE
+author:              Michael Karg
+maintainer:          michaelkarg77@gmail.com
+copyright:           VacationLabs
+category:            Database, Web
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+flag Optimize
+    description:    Enables an optimized build
+    default:        False
+
+
+executable RelationalRecord
+    main-is:        Main.hs
+    other-modules:  DataSource,
+                    DefineTable
+    build-depends:  base >=4.9 && <5,
+                    template-haskell,
+                    names-th,
+                    relational-record >= 0.1.5.1,
+                    relational-query-HDBC,
+                    relational-query,
+                    relational-schemas >= 0.1.3.2,
+                    persistable-record,
+                    th-data-compat,
+                    HDBC-session,
+                    HDBC,
+                    HDBC-postgresql,
+                    aeson >= 1.0.2,
+                    aeson-pretty >= 0.8.2,
+                    text,
+                    unordered-containers,
+                    vector,
+                    data-default,
+                    bytestring,
+                    random,
+                    time
+
+    hs-source-dirs: src
+
+    ghc-options:    -threaded -rtsopts -with-rtsopts=-N
+
+    if flag(Optimize)
+        ghc-options:    -O2 -funbox-strict-fields
+    else
+        ghc-options:    -Wall
+
+    default-language: Haskell2010
+
+
+
+source-repository head
+  type:     git
+  location: https://github.com/vacationlabs/haskell-webapps

RelationalRecord/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

RelationalRecord/db/bootstrap.sql

@@ -0,0 +1,45 @@
+/*
+    Some sample data
+*/
+
+insert into
+    tenants (name, first_name, last_name, email, phone, backoffice_domain)
+    values ('hansk', 'Hans', 'Klingelheller', 'hans@klingelheller.com', '12345', 'klingelheller.com');
+insert into
+    tenants (name, first_name, last_name, email, phone, backoffice_domain)
+    values ('marym', 'Mary', 'Miller', 'marym@gmailll.com', '9012345', 'mary.domain.info');
+insert into
+    tenants (name, first_name, last_name, email, phone, backoffice_domain)
+    values ('pikachu', 'Pika', 'Chu', 'pika@pokemon.jp', '2290125', 'pkchu.pokemon.com');
+
+insert into
+    roles (tenant_id, name, permissions)
+    values (1, 'good cop', 'foo,bar,baz');
+insert into
+    roles (tenant_id, name, permissions)
+    values (2, 'bad cop', 'baz');
+insert into
+    roles (tenant_id, name, permissions)
+    values (2, 'neutral', 'null,nil');
+
+insert into
+    users (tenant_id, username, password)
+    values (1, 'testuser1', 'testpass1');
+insert into
+    users (tenant_id, username, password)
+    values (1, 'testuser2', 'testpass2');
+insert into
+    users (tenant_id, username, password)
+    values (2, 'testuser3', 'testpass3');
+insert into
+    users (tenant_id, username, password)
+    values (3, 'testuser4', 'testpass4');
+
+insert into users_roles values (1, 1);
+insert into users_roles values (1, 2);
+insert into users_roles values (1, 3);
+insert into users_roles values (2, 2);
+insert into users_roles values (2, 3);
+insert into users_roles values (3, 1);
+
+update tenants set status = 'active', owner_id = 2 where id = 2;

RelationalRecord/db/schema.sql

@@ -0,0 +1,228 @@
+
+-- copy of /ServantOpaleye/db/schema.sql
+
+-- modified to circumvent postgres arrays
+
+
+--
+-- Tenants
+--
+
+create type tenant_status as enum('active', 'inactive', 'new');
+create table tenants(
+       id serial primary key
+       ,created_at timestamp with time zone not null default current_timestamp
+       ,updated_at timestamp with time zone not null default current_timestamp
+       ,name text not null
+       ,first_name text not null
+       ,last_name text not null
+       ,email text not null
+       ,phone text not null
+       ,status tenant_status not null default 'inactive'
+       ,owner_id integer
+       ,backoffice_domain text not null
+       constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null)
+);
+create unique index idx_index_owner_id on tenants(owner_id);
+create index idx_status on tenants(status);
+create index idx_tenants_created_at on tenants(created_at);
+create index idx_tenants_updated_at on tenants(updated_at);
+create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain));
+
+--
+-- Users
+--
+
+create type user_status as enum('active', 'inactive', 'blocked');
+create table users(
+       id serial primary key
+       ,created_at timestamp with time zone not null default current_timestamp
+       ,updated_at timestamp with time zone not null default current_timestamp
+       ,tenant_id integer not null references tenants(id)
+       ,username text not null
+       ,password text not null
+       ,first_name text
+       ,last_name text
+       ,status user_status not null default 'inactive'
+);
+
+create unique index idx_users_username on users(lower(username));
+create index idx_users_created_at on users(created_at);
+create index idx_users_updated_at on users(updated_at);
+create index idx_users_status on users(status);
+
+alter table tenants
+      add constraint fk_tenants_owner_id
+      foreign key (owner_id)
+      references users(id);
+
+--
+-- Roles
+--
+-- TODO: Write a CHECK CONSTRAINT that ensures that permissions[] contains only
+-- those permissions that the Haskell ADT can recognize
+
+create table roles(
+       id serial primary key
+       ,tenant_id integer not null references tenants(id)
+       ,name text not null
+       -- ,permissions text[] not null constraint at_least_one_permission check (array_length(permissions, 1)>0)
+       ,permissions text not null constraint at_least_one_permission check (char_length(permissions)>0)
+       ,created_at timestamp with time zone not null default current_timestamp
+       ,updated_at timestamp with time zone not null default current_timestamp
+);
+create unique index idx_roles_name on roles(tenant_id, lower(name));
+create index idx_roles_created_at on roles(created_at);
+create index idx_roles_updated_at on roles(updated_at);
+
+--
+-- User<>roles
+--
+-- Join-through table between users and roles
+--
+
+create table users_roles(
+       user_id integer not null references users(id)
+       ,role_id integer not null references roles(id)
+);
+create unique index idx_users_roles on users_roles(user_id, role_id);
+
+
+--
+-- Audit log
+--
+
+create table audit_logs(
+       id serial primary key
+       ,tenant_id integer not null references tenants(id)
+       ,user_id integer references users(id)
+       ,changed_by_system boolean not null default false
+       ,auditable_id integer not null
+       ,auditable_table_name text not null
+       ,summary text not null
+       ,changes jsonb default '{}'::jsonb not null
+       ,created_at timestamp with time zone not null default current_timestamp
+       constraint ensure_user_id check ((user_id is not null and not changed_by_system) or (user_id is null and changed_by_system))
+);
+create index idx_audit_logs_auditable_row on audit_logs(auditable_id, auditable_table_name);
+create index idx_audit_logs_tenant_user_id on audit_logs(tenant_id, user_id);
+create index idx_audit_logs_created_at on audit_logs(created_at);
+-- TODO: index on audit_logs(changes)?
+
+--
+-- Products
+--
+-- TODO: Evolve this schema to have a "price on request" feature. Evolve this
+-- say whether the comparison_price is computed automatically or manually set by
+-- the user.
+--
+-- TODO: do we need an is_deleted housekeeping column in every table? Is that
+-- really required, given that we have an audit log?
+
+create type product_type as enum('physical', 'digital');
+create table products(
+       id serial primary key
+       ,created_at timestamp with time zone not null default current_timestamp
+       ,updated_at timestamp with time zone not null default current_timestamp
+       ,tenant_id integer not null references tenants(id)
+       ,name text not null
+       ,description text
+       ,url_slug text not null
+       -- ,tags text[] not null default '{}'
+       ,tags text not null default ''
+       ,currency char(3) not null
+       ,advertised_price numeric not null
+       ,comparison_price numeric not null
+
+       -- NOTE: Adding the cost-price as an optional column to make the JSON
+       -- responses dependent upon the persmission of the signed-in user.
+       ,cost_price numeric
+       ,type product_type not null
+       ,is_published boolean not null default false
+       ,properties jsonb
+);
+
+create unique index idx_products_name on products(tenant_id, lower(name));
+create unique index idx_products_url_sluf on products(tenant_id, lower(url_slug));
+create index idx_products_created_at on products(created_at);
+create index idx_products_updated_at on products(updated_at);
+create index idx_products_comparison_price on products(comparison_price);
+create index idx_products_tags on products(tags); -- products using gin(tags);
+create index idx_product_type on products(type);
+create index idx_product_is_published on products(is_published);
+
+--
+-- Variants
+--
+
+create type weight_unit as enum('grams', 'kgs', 'pounds');
+create table variants(
+       id serial primary key
+       ,created_at timestamp with time zone not null default current_timestamp
+       ,updated_at timestamp with time zone not null default current_timestamp
+       ,tenant_id integer not null references tenants(id)
+       ,product_id integer not null references products(id)
+       ,name text not null
+       ,sku text not null
+       ,currency char(3) not null
+       ,price numeric not null
+       ,quantity integer
+       ,weight_in_grams integer
+       ,weight_display_unit weight_unit
+);
+
+-- TODO: Do we need an index on variants(tenant_id) & varianta(product_id)
+create index idx_variants_created_at on variants(created_at);
+create index idx_variants_updated_at on variants(updated_at);
+
+create function check_weight_reqd_for_physical_products() returns trigger as $$
+       declare
+            ptype product_type;
+       begin
+            select type into ptype from products where id=new.product_id;
+            if (ptype='physical') and (weight_in_grams is null or weight_display_unit is null) then
+               raise exception 'weight_in_grams and weight_display_unit, both, should be set only for physical products';
+            end if;
+
+            return new;
+       end;
+$$ language plpgsql;
+
+create constraint trigger trig_weight_reqd_for_physical_products
+       after insert or update on variants
+       deferrable initially deferred
+       for each row
+       -- when ((new.weight_in_grams is not null) or (new.weight_display_unit is not null))
+       execute procedure check_weight_reqd_for_physical_products();
+
+-- TODO: Need a trigger-contraint to ensure that, if the product-type is chaged
+-- to 'physical' then weights have been added to variants. This raises the
+-- question about what is a better approach in DB design?
+--
+-- 1. Different triggers for every such condition, or
+--
+-- 2. One unified 'validation' trigger that will be fired anytime a row in
+-- products, variants, images, or any other related table is created, updated,
+-- or deleted?
+--
+-- It seem (2) is more in line with the Haskell philosophy, i.e.
+-- idempotent/stateless actions.
+
+create table photos(
+       id serial primary key
+       ,created_at timestamp with time zone not null default current_timestamp
+       -- no updated_at on purpose
+       ,tenant_id integer not null references tenants(id)
+       ,product_id integer references products(id)
+       ,variant_id integer references variants(id)
+       ,file_size integer not null
+       ,file_type integer not null
+       ,file_original_path text not null
+       ,processed_styles jsonb
+       ,fingerprint text not null
+       constraint ensure_photo_reference check (product_id is not null or variant_id is not null)
+);
+create index idx_photos_created_at on photos(created_at);
+create index idx_photos_fingerprint on photos(fingerprint);
+create index idx_photos_variant_id on photos(variant_id);
+create index idx_photos_product_id on photos(product_id);