Advanced DB Mappings

Overview

In this chapter we’ll build upon what we did in the last chapter:

  • We’ll modify the tenants table, to be a little more typesafe by changing the type of the status column to a Postgres ENUM (rather than a text) and mapping it to a Haskell ADT.
  • We’ll add a new table called products that will be used to store information of various products in our hypothetical ecommerce store
  • We’ll change the id and createdAt columns to be read-only, for greater type-safety while inserting records.
  • We’ll change the primary keys, tenants.id and products.id to TenantId and ProductId respecively. Again, for greater type-safety.

SQL for table creation

--
-- 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));

---
--- Products
---

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 '{}'
       ,currency char(3) not null
       ,advertised_price numeric not null
       ,comparison_price numeric not null
       ,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 using gin(tags);
create index idx_product_type on products(type);
create index idx_product_is_published on products(is_published);

Code that we’ll run through

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
{-# LANGUAGE Arrows                #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}

module Main where

import           Data.Aeson
import           Data.Profunctor.Product
import           Data.Profunctor.Product.Default
import           Data.Profunctor.Product.TH           (makeAdaptorAndInstance)
import           Data.Scientific
import           Data.ByteString hiding (putStrLn)
import           Data.Text
import           Data.Time
import           Opaleye

import           Database.PostgreSQL.Simple
import           Database.PostgreSQL.Simple.FromField (Conversion,
                                                       FromField (..),
                                                       ResultError (..),
                                                       returnError)

import           Control.Arrow
import           Prelude                              hiding (id)

-- Tenant stuff

newtype TenantId = TenantId Int deriving(Show)

data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew
  deriving (Show)

data TenantPoly key name fname lname email phone status b_domain = Tenant
  { tenant_id               :: key
  , tenant_name             :: name
  , tenant_firstname        :: fname
  , tenant_lastname         :: lname
  , tenant_email            :: email
  , tenant_phone            :: phone
  , tenant_status           :: status
  , tenant_backofficedomain :: b_domain
  } deriving (Show)

type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus Text

type TenantTableW = TenantPoly
  (Maybe (Column PGInt4))
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)

type TenantTableR = TenantPoly
  (Column PGInt4)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)

-- Product stuff

newtype ProductId = ProductId Int deriving (Show)

data ProductType = ProductPhysical | ProductDigital deriving (Show)

data ProductPoly id created_at updated_at tenant_id name description url_slug tags currency advertised_price comparison_price cost_price product_type is_published properties = Product {
      product_id               :: id
    , product_created_at       :: created_at
    , product_updated_at       :: updated_at
    , product_tenant_id        :: tenant_id
    , product_name             :: name
    , product_description      :: description
    , product_url_slug         :: url_slug
    , product_tags             :: tags
    , product_currency         :: currency
    , product_advertised_price :: advertised_price
    , product_comparison_price :: comparison_price
    , product_cost_price       :: cost_price
    , product_product_type     :: product_type
    , product_is_published     :: is_published
    , product_properties       :: properties
  } deriving (Show)

type Product = ProductPoly ProductId UTCTime UTCTime TenantId Text (Maybe Text) Text [Text] Text Scientific Scientific (Maybe Scientific) ProductType Bool Value
type ProductTableW = ProductPoly
  (Maybe (Column PGInt4))
  (Maybe (Column PGTimestamptz))
  (Maybe (Column PGTimestamptz))
  (Column PGInt4)
  (Column PGText)
  (Maybe (Column (Nullable PGText)))
  (Column PGText)
  (Column (PGArray PGText))
  (Column PGText)
  (Column PGFloat8)
  (Column PGFloat8)
  (Maybe (Column (Nullable PGFloat8)))
  (Column PGText)
  (Column PGBool)
  (Column PGJsonb)

type ProductTableR = ProductPoly
  (Column PGInt4)
  (Column PGTimestamptz)
  (Column PGTimestamptz)
  (Column PGInt4)
  (Column PGText)
  (Column (Nullable PGText))
  (Column PGText)
  (Column (PGArray PGText))
  (Column PGText)
  (Column PGFloat8)
  (Column PGFloat8)
  (Column (Nullable PGFloat8))
  (Column PGText)
  (Column PGBool)
  (Column PGJsonb)

-- Table defs

$(makeAdaptorAndInstance "pTenant" ''TenantPoly)
tenantTable :: Table TenantTableW TenantTableR
tenantTable = Table "tenants" (pTenant
   Tenant {
     tenant_id = (optional "id"),
     tenant_name = (required "name"),
     tenant_firstname = (required "first_name"),
     tenant_lastname = (required "last_name"),
     tenant_email = (required "email"),
     tenant_phone = (required "phone"),
     tenant_status = (required "status"),
     tenant_backofficedomain = (required "backoffice_domain")
   }
 )

$(makeAdaptorAndInstance "pProduct" ''ProductPoly)

productTable :: Table ProductTableW ProductTableR
productTable = Table "products" (pProduct
    Product {
      product_id = (optional "id"),
      product_created_at = (optional "created_at"),
      product_updated_at = (optional "updated_at"),
      product_tenant_id = (required "tenant_id"),
      product_name = (required "name"),
      product_description = (optional "description"),
      product_url_slug = (required "url_slug"),
      product_tags = (required "tags"),
      product_currency = (required "currency"),
      product_advertised_price = (required "advertised_price"),
      product_comparison_price = (required "comparison_price"),
      product_cost_price = (optional "cost_price"),
      product_product_type = (required "type"),
      product_is_published = (required "is_published"),
      product_properties = (required "properties") })

-- Instance declarations for custom types
-- For TenantStatus

instance FromField TenantStatus where
  fromField field mb_bytestring = makeTenantStatus mb_bytestring
    where
    makeTenantStatus :: Maybe ByteString -> Conversion TenantStatus
    makeTenantStatus (Just "active") = return TenantStatusActive
    makeTenantStatus (Just "inactive") = return TenantStatusInActive
    makeTenantStatus (Just "new") = return TenantStatusNew
    makeTenantStatus (Just _) = returnError ConversionFailed field "Unrecognized tenant status"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty tenant status"

instance QueryRunnerColumnDefault PGText TenantStatus where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For ProductType

instance FromField ProductType where
  fromField field mb_bytestring = makeProductType mb_bytestring
    where
    makeProductType :: Maybe ByteString -> Conversion ProductType
    makeProductType (Just "physical") = return ProductPhysical
    makeProductType (Just "digital") = return ProductDigital
    makeProductType (Just _) = returnError ConversionFailed field "Unrecognized product type"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty product type"

instance QueryRunnerColumnDefault PGText ProductType where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For productId

instance FromField ProductId where
  fromField field mb_bytestring = ProductId <$> fromField field mb_bytestring

instance QueryRunnerColumnDefault PGInt4 ProductId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn
-- For TenantId
instance FromField TenantId where
  fromField field mb_bytestring = TenantId <$> fromField field mb_bytestring

instance QueryRunnerColumnDefault PGInt4 TenantId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For Scientific we didn't have to implement instance of fromField
-- because it is already defined in postgresql-simple

instance QueryRunnerColumnDefault PGFloat8 Scientific where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- Default instance definitions for custom datatypes for converison to
-- PG types while writing into tables

-- For Tenant stuff

instance Default Constant TenantStatus (Column PGText) where
  def = Constant def'
    where
      def' :: TenantStatus -> (Column PGText)
      def' TenantStatusActive = pgStrictText "active"
      def' TenantStatusInActive = pgStrictText "inactive"
      def' TenantStatusNew = pgStrictText "new"

instance Default Constant TenantId (Maybe (Column PGInt4)) where
  def = Constant (\(TenantId x) -> Just $ pgInt4 x)

-- For Product stuff

instance Default Constant ProductType (Column PGText) where
  def = Constant def'
    where
      def' :: ProductType -> (Column PGText)
      def' ProductDigital = pgStrictText "digital"
      def' ProductPhysical = pgStrictText "physical"

instance Default Constant ProductId (Maybe (Column PGInt4)) where
  def = Constant (\(ProductId x) -> Just $ constant x)

instance Default Constant Scientific (Column PGFloat8) where
  def = Constant (pgDouble.toRealFloat)

instance Default Constant Scientific (Column (Nullable PGFloat8)) where
  def = Constant (toNullable.constant)

instance Default Constant Text (Column (Nullable PGText)) where
  def = Constant (toNullable.pgStrictText)

instance Default Constant UTCTime (Maybe (Column PGTimestamptz)) where
  def = Constant ((Just).pgUTCTime)

instance Default Constant TenantId (Column PGInt4) where
  def = Constant (\(TenantId x) -> constant x)

getProducts :: IO [Product]
getProducts = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ queryTable productTable

getTenants :: IO [Tenant]
getTenants = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ queryTable tenantTable

insertTenant :: IO ()
insertTenant = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runInsertManyReturning conn tenantTable [constant getTestTenant] (\x -> x) :: IO [Tenant]
  return ()

insertProduct :: IO ()
insertProduct = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  product <- getTestProduct
  runInsertManyReturning conn productTable [constant product] (\x -> x) :: IO [Product]
  return ()

getTestTenant :: TenantIncoming
getTestTenant = Tenant {
  tenant_id = (),
  tenant_name = "Tenant Bob",
  tenant_firstname = "Bobby",
  tenant_lastname = "Bob",
  tenant_email = "bob@gmail.com",
  tenant_phone = "2255",
  tenant_status = TenantStatusInActive,
  tenant_backofficedomain = "bob.com"
}

getTestProduct :: IO Product
getTestProduct = do
  time <- getCurrentTime
  let (Just properties) =  decode "{\"weight\": \"200gm\"}" :: Maybe Value
  return $ Product {
    product_id = (ProductId 5),
    product_created_at = time,
    product_updated_at = time,
    product_tenant_id = (TenantId 5),
    product_name = "snacks",
    product_description = Just "",
    product_url_slug = "",
    product_tags = ["tag1", "tag2"],
    product_currency = "INR",
    product_advertised_price = 30,
    product_comparison_price = 45,
    product_cost_price = Nothing,
    product_product_type = ProductPhysical,
    product_is_published = False,
    product_properties = properties
  }

main :: IO ()
main = do
  insertTenant
  insertProduct
  tenants <- getTenants
  products <- getProducts
  putStrLn $ show tenants
  putStrLn $ show products

-- Output
-- 
-- [Tenant {tenant_id = TenantId 1, tenant_name = "Tenant John", tenant_firstname
-- = "John", tenant_lastname = "Honai", tenant_email = "john@mail.com", tenant_pho
-- ne = "2255", tenant_status = TenantStatusInActive, tenant_backofficedomain = "j
-- honhonai.com"}]
-- [Product {product_id = ProductId 1, product_created_at = 2016-11-27 10:24:31.60
-- 0244 UTC, product_updated_at = 2016-11-27 10:24:31.600244 UTC, product_tenant_i
-- d = TenantId 1, product_name = "Biscuits", product_description = Just "Biscuits
-- , you know..", product_url_slug = "biscuits", product_tags = ["bakery","snacks"
-- ], product_currency = "INR", product_advertised_price = 40.0, product_compariso
-- n_price = 55.0, product_cost_price = Just 34.0, product_product_type = ProductP
-- hysical, product_is_published = False, product_properties = Object (fromList [(
-- "weight",String "200gm")])}]

Warning

In the code given above, we are using PGFloat8 to represent monetary values. This is a bad idea and absolutely not recommended. We are forced to do this because Opaleye’s support for Postgres NUMERIC datatype is not really complete.

Core mechanism for mapping custom Haskell types to PG types

There are three typeclasses at play in converting values between Haskell types (like Int, Text and other user defined types) and PG types (like PGInt4, PGText etc). These are:

  • FromField
  • QueryRunnerColumnDefault
  • Default (not Data.Default)

FromField

This is a typeclass defined by the postgresql-simple library. This typeclass decides how values read from database are converted to their Haskell counterparts. It is defined as:

class FromField a where
  fromField :: FieldParser a

type FieldParser a = Field -> Maybe ByteString -> Conversion a

The basic idea of this typeclass is simple. It wants you to define a function fromField which will be passed the following:

  • Field - a record holding a lot of metadata about the underlying Postgres column
  • Maybe ByteString - the raw value of that column

You are expected to return a Conversion a which is conceptually an action, which when evaluated will do the conversion from Maybe ByteString to your desired type a.

Diligent readers will immediately have the following questions:

What kind of metadata does Field have?

name :: Field -> Maybe ByteString
tableOid :: Field -> Maybe Oid
tableColumn :: Field -> Int
format :: Field -> Format
typeOid :: Field -> Oid
-- and more

How does one write a (Conversion a) action?

Good question! The answer is that we (the authors of this tutorial) don’t know! And we didn’t feel the need to find out as well. Because you already have the fromField functions for a lot of pre-defined Haskell types. In practice, you usually compose them to obtain your desired Conversion action. Read the other sections in this chapter to find exampler of how to do this.

QueryRunnerColumnDefault

This typeclass is used by Opaleye to do the conversion from postgres types defined by Opaleye, into Haskell types. It is defined as

class QueryRunnerColumnDefault pgType haskellType where
  queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType

Opaleye provides with a function

fieldQueryRunnerColumn:: FromField haskell => QueryRunnerColumn pgType haskell

As the type signature shows, fieldQueryRunnerColumn can return a value of type QueryRunnerColumn a b as long as b is an instance of FromField typeclass. So once we define an instance of FromField for our type, all we have to do is the following.

For the data type TenantStatus that we saw earlier,

instance QueryRunnerColumnDefault PGText TenantStatus where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

Default

Note

This is not the Data.Default that you may be familiar with. This is Data.Profunctor.Product.Default

This is a typeclass that Opaleye uses to convert Haskell values to Postgres values while writing to the database. It is defined as:

class Default (p :: * -> * -> *) a b where
  def :: p a b

You see a type variable p, that this definition required. Opaleye provided with a type Constant that can be used here. It is defined as

newtype Constant haskells columns
  = Constant {constantExplicit :: haskells -> columns}

So if we are defining a Default instance for the TenantStatus we saw earlier, it would be something like this.

instance Default Constant TenantStatus (Column PGText) where
  def = Constant def'
    where
      def' :: TenantStatus -> (Column PGText)
      def' TenantStatusActive = pgStrictText "active"
      def' TenantStatusInActive = pgStrictText "inactive"
      def' TenantStatusNew = pgStrictText "new"

Newtypes for primary keys

Ideally, we would like to represent our primary keys using newtypes that wrap around an Int. For example:

newtype TenantId = TenantId Int
newtype ProductId = ProductId Int

This is generally done to extract greater type-safety out of the system. For instance, doing this would prevent the following class of errors:

  • Comparing a TenantId to a ProductId, which would rarely make sense.
  • Passing a TenantId to a function which is expecting a ProductId
  • At an SQL level, joining the tenantTable with the productTable by matching tenants.id to products.id

But it seems that Opaleye’s support for this feature is not really ready. So we will skip it for now.

Mapping ENUMs to Haskell ADTs

Here’s what our ADT for TenantStatus looks like:

data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew
  deriving (Show)

Here’s how we would setup the DB => Haskell conversion. If you notice, we didn’t really need to bother with how to build Conversion TenantStatus because once we know what the incoming ByteString is, we know exactly which ADT value it should map to. We simply return that value, since Conversion is a Monad.

instance FromField TenantStatus where
  fromField field mb_bytestring = makeTenantStatus mb_bytestring
    where
    makeTenantStatus :: Maybe ByteString -> Conversion TenantStatus
    makeTenantStatus (Just "active") = return TenantStatusActive
    makeTenantStatus (Just "inactive") = return TenantStatusInActive
    makeTenantStatus (Just "new") = return TenantStatusNew
    makeTenantStatus (Just _) = returnError ConversionFailed field "Unrecognized tenant status"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty tenant status"

instance QueryRunnerColumnDefault PGText TenantStatus where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

TODO: As we saw in the Typeclasses section, Opaleye requires the QueryRunnerColumnDefault typeclass instances for converting from data read from Database to Haskell values. the function fieldQueryRunnerColumn can return the value of the required type as long as there is a FromField instance for the required type.

Now, let’s look at how to setup the Haskell => DB conversion.

instance Default Constant TenantStatus (Column PGText) where
  def = Constant def'
    where
      def' :: TenantStatus -> (Column PGText)
      def' TenantStatusActive = pgStrictText "active"
      def' TenantStatusInActive = pgStrictText "inactive"
      def' TenantStatusNew = pgStrictText "new"

Handing Postgres Arrays

Postgresql Array column are represented by the PGArray type. It can take an additional type to represent the kind of the array. So if the column is text[], the type needs to be PGArray PGText.

If you look at the earlier code, you can see that the output contains a list for the tag fields.

Handling JSONB

The type that represents jsonb postgresql columns in Opaleye is PGJsonb. It will support any type that has a ToJSON/FromJSON instances defined for it.

ToJSON/FromJSON typeclasses are exported by the Aeson json library.

This is how it is done. Let us change the properties field of the Product type we saw earlier into a record in see how we can store it in a jsonb field.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
{-# LANGUAGE Arrows                #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}

module Main where

import           Data.Aeson
import           Data.Aeson.Types
import           Data.Profunctor.Product
import           Data.Profunctor.Product.Default
import           Data.Profunctor.Product.TH           (makeAdaptorAndInstance)
import           Data.Scientific
import           Data.ByteString hiding (putStrLn)
import           Data.Text
import           Data.Time
import           Opaleye

import           Database.PostgreSQL.Simple
import           Database.PostgreSQL.Simple.FromField (Conversion,
                                                       FromField (..),
                                                       ResultError (..),
                                                       returnError)

import           Control.Arrow
import           Prelude                              hiding (id)


readOnly :: String -> TableProperties () (Column a)
readOnly = lmap (const Nothing) . optional

-- Tenant stuff

newtype TenantId = TenantId Int deriving(Show)

data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew
  deriving (Show)

data TenantPoly key name fname lname email phone status b_domain = Tenant
  { tenant_id               :: key
  , tenant_name             :: name
  , tenant_firstname        :: fname
  , tenant_lastname         :: lname
  , tenant_email            :: email
  , tenant_phone            :: phone
  , tenant_status           :: status
  , tenant_backofficedomain :: b_domain
  } deriving (Show)

type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus Text

type TenantTableW = TenantPoly
  (Maybe (Column PGInt4))
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)

type TenantTableR = TenantPoly
  (Column PGInt4)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)

-- Product stuff

newtype ProductId = ProductId Int deriving (Show)

data ProductType = ProductPhysical | ProductDigital deriving (Show)

data ProductProperties = ProductProperties { product_color :: String, product_weight :: String} deriving (Show)

data ProductPoly id created_at updated_at tenant_id name description url_slug tags currency advertised_price comparison_price cost_price product_type is_published properties = Product {
      product_id               :: id
    , product_created_at       :: created_at
    , product_updated_at       :: updated_at
    , product_tenant_id        :: tenant_id
    , product_name             :: name
    , product_description      :: description
    , product_url_slug         :: url_slug
    , product_tags             :: tags
    , product_currency         :: currency
    , product_advertised_price :: advertised_price
    , product_comparison_price :: comparison_price
    , product_cost_price       :: cost_price
    , product_product_type     :: product_type
    , product_is_published     :: is_published
    , product_properties       :: properties
  } deriving (Show)

type Product = ProductPoly ProductId UTCTime UTCTime TenantId Text (Maybe Text) Text [Text] Text Scientific Scientific (Maybe Scientific) ProductType Bool ProductProperties
type ProductTableW = ProductPoly
  (Maybe (Column PGInt4))
  (Maybe (Column PGTimestamptz))
  (Maybe (Column PGTimestamptz))
  (Column PGInt4)
  (Column PGText)
  (Maybe (Column (Nullable PGText)))
  (Column PGText)
  (Column (PGArray PGText))
  (Column PGText)
  (Column PGFloat8)
  (Column PGFloat8)
  (Maybe (Column (Nullable PGFloat8)))
  (Column PGText)
  (Column PGBool)
  (Column PGJsonb)

type ProductTableR = ProductPoly
  (Column PGInt4)
  (Column PGTimestamptz)
  (Column PGTimestamptz)
  (Column PGInt4)
  (Column PGText)
  (Column (Nullable PGText))
  (Column PGText)
  (Column (PGArray PGText))
  (Column PGText)
  (Column PGFloat8)
  (Column PGFloat8)
  (Column (Nullable PGFloat8))
  (Column PGText)
  (Column PGBool)
  (Column PGJsonb)

-- Table defs

$(makeAdaptorAndInstance "pTenant" ''TenantPoly)
tenantTable :: Table TenantTableW TenantTableR
tenantTable = Table "tenants" (pTenant
   Tenant {
     tenant_id = (optional "id"),
     tenant_name = (required "name"),
     tenant_firstname = (required "first_name"),
     tenant_lastname = (required "last_name"),
     tenant_email = (required "email"),
     tenant_phone = (required "phone"),
     tenant_status = (required "status"),
     tenant_backofficedomain = (required "backoffice_domain")
   }
 )

$(makeAdaptorAndInstance "pProduct" ''ProductPoly)

productTable :: Table ProductTableW ProductTableR
productTable = Table "products" (pProduct
    Product {
      product_id = (optional "id"),
      product_created_at = (optional "created_at"),
      product_updated_at = (optional "updated_at"),
      product_tenant_id = (required "tenant_id"),
      product_name = (required "name"),
      product_description = (optional "description"),
      product_url_slug = (required "url_slug"),
      product_tags = (required "tags"),
      product_currency = (required "currency"),
      product_advertised_price = (required "advertised_price"),
      product_comparison_price = (required "comparison_price"),
      product_cost_price = (optional "cost_price"),
      product_product_type = (required "type"),
      product_is_published = (required "is_published"),
      product_properties = (required "properties") })

-- Instance declarations for custom types
-- For TenantStatus

instance FromField TenantStatus where
  fromField field mb_bytestring = makeTenantStatus mb_bytestring
    where
    makeTenantStatus :: Maybe ByteString -> Conversion TenantStatus
    makeTenantStatus (Just "active") = return TenantStatusActive
    makeTenantStatus (Just "inactive") = return TenantStatusInActive
    makeTenantStatus (Just "new") = return TenantStatusNew
    makeTenantStatus (Just _) = returnError ConversionFailed field "Unrecognized tenant status"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty tenant status"

instance QueryRunnerColumnDefault PGText TenantStatus where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For ProductType

instance FromField ProductType where
  fromField field mb_bytestring = makeProductType mb_bytestring
    where
    makeProductType :: Maybe ByteString -> Conversion ProductType
    makeProductType (Just "physical") = return ProductPhysical
    makeProductType (Just "digital") = return ProductDigital
    makeProductType (Just _) = returnError ConversionFailed field "Unrecognized product type"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty product type"

instance QueryRunnerColumnDefault PGText ProductType where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For productId

instance FromField ProductId where
  fromField field mb_bytestring = ProductId <$> fromField field mb_bytestring

instance QueryRunnerColumnDefault PGInt4 ProductId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn
-- For TenantId
instance FromField TenantId where
  fromField field mb_bytestring = TenantId <$> fromField field mb_bytestring

instance QueryRunnerColumnDefault PGInt4 TenantId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For Scientific we didn't have to implement instance of fromField
-- because it is already defined in postgresql-simple

instance QueryRunnerColumnDefault PGFloat8 Scientific where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- Default instance definitions for custom datatypes for converison to
-- PG types while writing into tables

-- For Tenant stuff

instance Default Constant TenantStatus (Column PGText) where
  def = Constant def'
    where
      def' :: TenantStatus -> (Column PGText)
      def' TenantStatusActive = pgStrictText "active"
      def' TenantStatusInActive = pgStrictText "inactive"
      def' TenantStatusNew = pgStrictText "new"

instance Default Constant TenantId (Maybe (Column PGInt4)) where
  def = Constant (\(TenantId x) -> Just $ pgInt4 x)

-- For Product stuff

instance Default Constant ProductType (Column PGText) where
  def = Constant def'
    where
      def' :: ProductType -> (Column PGText)
      def' ProductDigital = pgStrictText "digital"
      def' ProductPhysical = pgStrictText "physical"

instance Default Constant ProductId (Maybe (Column PGInt4)) where
  def = Constant (\(ProductId x) -> Just $ constant x)

instance Default Constant Scientific (Column PGFloat8) where
  def = Constant (pgDouble.toRealFloat)

instance Default Constant Scientific (Column (Nullable PGFloat8)) where
  def = Constant (toNullable.constant)

instance Default Constant Text (Column (Nullable PGText)) where
  def = Constant (toNullable.pgStrictText)

instance Default Constant UTCTime (Maybe (Column PGTimestamptz)) where
  def = Constant ((Just).pgUTCTime)

instance Default Constant TenantId (Column PGInt4) where
  def = Constant (\(TenantId x) -> constant x)

-- FromJSON/ToJSON instances for properties

instance FromJSON ProductProperties where
  parseJSON (Object v) = ProductProperties <$> v .: "color" <*> v .: "weight"
  parseJSON invalid = typeMismatch "Unrecognized format for product properties" invalid

instance ToJSON ProductProperties where
  toJSON ProductProperties {product_color = color, product_weight = weight} = object ["color" .= color, "weight" .= weight]

instance FromField ProductProperties where
  fromField field mb = do
    v <-  fromField field mb
    valueToProductProperties v
    where
      valueToProductProperties :: Value -> Conversion ProductProperties
      valueToProductProperties v = case fromJSON v of
        Success a -> return a
        Error err -> returnError ConversionFailed field "Cannot parse product properties"

instance QueryRunnerColumnDefault PGJsonb ProductProperties where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

instance Default Constant ProductProperties (Column PGJsonb) where
  def = Constant (\pp -> pgValueJSONB $ toJSON pp)

getProducts :: IO [Product]
getProducts = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ queryTable productTable

getTenants :: IO [Tenant]
getTenants = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ queryTable tenantTable

insertTenant :: IO ()
insertTenant = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runInsertManyReturning conn tenantTable [constant getTestTenant] (\x -> x) :: IO [Tenant]
  return ()

insertProduct :: IO ()
insertProduct = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  product <- getTestProduct
  runInsertManyReturning conn productTable [constant product] (\x -> x) :: IO [Product]
  return ()
  
getTestTenant :: Tenant
getTestTenant = Tenant (TenantId 5) "Tenant Bob" "Bobby" "Bob" "bob@mail.com" "2255" TenantStatusInActive "bob.com"

getTestProduct :: IO Product
getTestProduct = do
  time <- getCurrentTime
  let properties =  ProductProperties { product_color = "red", product_weight = "200gm"}
  return $ Product (ProductId 5) time time (TenantId 5) "snacks" (Just "") "" ["tag1", "tag2"] "INR" 30 45 Nothing ProductPhysical False properties

main :: IO ()
main = do
  insertTenant
  insertProduct
  tenants <- getTenants
  products <- getProducts
  putStrLn $ show tenants
  putStrLn $ show products

-- Output
-- 
-- 
-- [Tenant {tenant_id = TenantId 1, tenant_name = "Tenant John", tenant_firstname = "John", tenant_lastname = "Honai", te
-- nant_email = "john@mail.com", tenant_phone = "2255", tenant_status = TenantStatusInActive, tenant_backofficedomain = "
-- jhonhonai.com"},Tenant {tenant_id = TenantId 5, tenant_name = "Tenant Bob", tenant_firstname = "Bobby", tenant_lastnam
-- e = "Bob", tenant_email = "bob@mail.com", tenant_phone = "2255", tenant_status = TenantStatusInActive, tenant_backoffi
-- cedomain = "bob.com"}]
-- [Product {product_id = ProductId 5, product_created_at = 2016-11-28 12:31:40.085634 UTC, product_updated_at = 2016-11-
-- 28 12:31:40.085634 UTC, product_tenant_id = TenantId 5, product_name = "snacks", product_description = Just "", produc
-- t_url_slug = "", product_tags = ["tag1","tag2"], product_currency = "INR", product_advertised_price = 30.0, product_co
-- mparison_price = 45.0, product_cost_price = Nothing, product_product_type = ProductPhysical, product_is_published = Fa
-- lse, product_properties = ProductProperties {product_color = "red", product_weight = "200gm"}}]

In the emphasized lines in code above, we are defining instances to support json conversion. The binary operators .: and .= that you see are stuff exported by the Aeson json library. The basis of Json decoding/encoding is the aeson’s Value type. This type can represent any json value. It is defined as

data Value
  = Object !Object
  | Array !Array
  | String !Text
  | Number !Scientific
  | Bool !Bool
  | Null

The Object type is an alias for a HashMap, and Array for a Vector and so on.

The instances are our usual type conversion instances. The Value type has the instances built in, so we will use them for defining instances for ProductProperties. So when we define a FromField instance for ProductProperties, we use the fromField instance of the Value type. We are also handling errors that might occur while parsing and reporting via postgresql’s error reporting functions.

In the last instance, we are using the Default instance of the aforementioned Value type to implement instance for ProductProperties. The toJSON converts our ProductProperties to Value type, and since there are already built in Default instance for Value type, we were able to call the constant function on it, to return the appropriate opaleye’s column type.

Making columns read-only

Sometimes we will want to make a certain column read only, accepting only values generated from the database. Here is how we can do it.

We have to define a new function readOnly, which will make the required field of type (), in the write types so we won’t be able to provide a value for writing.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
{-# LANGUAGE Arrows                #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}

module Main where

import           Data.Aeson
import           Data.Aeson.Types
import           Data.Profunctor
import           Data.Profunctor.Product
import           Data.Profunctor.Product.Default
import           Data.Profunctor.Product.TH           (makeAdaptorAndInstance)
import           Data.Scientific
import           Data.ByteString hiding (putStrLn)
import           Data.Text
import           Data.Time
import           Opaleye

import           Database.PostgreSQL.Simple
import           Database.PostgreSQL.Simple.FromField (Conversion,
                                                       FromField (..),
                                                       ResultError (..),
                                                       returnError)

import           Control.Arrow
import           Prelude                              hiding (id)


readOnly :: String -> TableProperties () (Column a)
readOnly = lmap (const Nothing) . optional

-- Tenant stuff

newtype TenantId = TenantId Int deriving(Show)

data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew
  deriving (Show)

data TenantPoly key name fname lname email phone status b_domain = Tenant
  { tenant_id               :: key
  , tenant_name             :: name
  , tenant_firstname        :: fname
  , tenant_lastname         :: lname
  , tenant_email            :: email
  , tenant_phone            :: phone
  , tenant_status           :: status
  , tenant_backofficedomain :: b_domain
  } deriving (Show)

type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus Text
type TenantIncoming = TenantPoly () Text Text Text Text Text TenantStatus Text

type TenantTableW = TenantPoly
  ()
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)

type TenantTableR = TenantPoly
  (Column PGInt4)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)
  (Column PGText)

-- Product stuff

newtype ProductId = ProductId Int deriving (Show)

data ProductType = ProductPhysical | ProductDigital deriving (Show)

data ProductProperties = ProductProperties { product_color :: String, product_weight :: String} deriving (Show)

data ProductPoly id created_at updated_at tenant_id name description url_slug tags currency advertised_price comparison_price cost_price product_type is_published properties = Product {
      product_id               :: id
    , product_created_at       :: created_at
    , product_updated_at       :: updated_at
    , product_tenant_id        :: tenant_id
    , product_name             :: name
    , product_description      :: description
    , product_url_slug         :: url_slug
    , product_tags             :: tags
    , product_currency         :: currency
    , product_advertised_price :: advertised_price
    , product_comparison_price :: comparison_price
    , product_cost_price       :: cost_price
    , product_product_type     :: product_type
    , product_is_published     :: is_published
    , product_properties       :: properties
  } deriving (Show)

type Product = ProductPoly ProductId UTCTime UTCTime TenantId Text (Maybe Text) Text [Text] Text Scientific Scientific (Maybe Scientific) ProductType Bool ProductProperties
type ProductTableW = ProductPoly
  (Maybe (Column PGInt4))
  (Maybe (Column PGTimestamptz))
  (Maybe (Column PGTimestamptz))
  (Column PGInt4)
  (Column PGText)
  (Maybe (Column (Nullable PGText)))
  (Column PGText)
  (Column (PGArray PGText))
  (Column PGText)
  (Column PGFloat8)
  (Column PGFloat8)
  (Maybe (Column (Nullable PGFloat8)))
  (Column PGText)
  (Column PGBool)
  (Column PGJsonb)

type ProductTableR = ProductPoly
  (Column PGInt4)
  (Column PGTimestamptz)
  (Column PGTimestamptz)
  (Column PGInt4)
  (Column PGText)
  (Column (Nullable PGText))
  (Column PGText)
  (Column (PGArray PGText))
  (Column PGText)
  (Column PGFloat8)
  (Column PGFloat8)
  (Column (Nullable PGFloat8))
  (Column PGText)
  (Column PGBool)
  (Column PGJsonb)

-- Table defs

$(makeAdaptorAndInstance "pTenant" ''TenantPoly)
tenantTable :: Table TenantTableW TenantTableR
tenantTable = Table "tenants" (pTenant
   Tenant {
     tenant_id = (readOnly "id"),
     tenant_name = (required "name"),
     tenant_firstname = (required "first_name"),
     tenant_lastname = (required "last_name"),
     tenant_email = (required "email"),
     tenant_phone = (required "phone"),
     tenant_status = (required "status"),
     tenant_backofficedomain = (required "backoffice_domain")
   }
 )

$(makeAdaptorAndInstance "pProduct" ''ProductPoly)

productTable :: Table ProductTableW ProductTableR
productTable = Table "products" (pProduct
    Product {
      product_id = (optional "id"),
      product_created_at = (optional "created_at"),
      product_updated_at = (optional "updated_at"),
      product_tenant_id = (required "tenant_id"),
      product_name = (required "name"),
      product_description = (optional "description"),
      product_url_slug = (required "url_slug"),
      product_tags = (required "tags"),
      product_currency = (required "currency"),
      product_advertised_price = (required "advertised_price"),
      product_comparison_price = (required "comparison_price"),
      product_cost_price = (optional "cost_price"),
      product_product_type = (required "type"),
      product_is_published = (required "is_published"),
      product_properties = (required "properties") })

-- Instance declarations for custom types
-- For TenantStatus

instance FromField TenantStatus where
  fromField field mb_bytestring = makeTenantStatus mb_bytestring
    where
    makeTenantStatus :: Maybe ByteString -> Conversion TenantStatus
    makeTenantStatus (Just "active") = return TenantStatusActive
    makeTenantStatus (Just "inactive") = return TenantStatusInActive
    makeTenantStatus (Just "new") = return TenantStatusNew
    makeTenantStatus (Just _) = returnError ConversionFailed field "Unrecognized tenant status"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty tenant status"

instance QueryRunnerColumnDefault PGText TenantStatus where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For ProductType

instance FromField ProductType where
  fromField field mb_bytestring = makeProductType mb_bytestring
    where
    makeProductType :: Maybe ByteString -> Conversion ProductType
    makeProductType (Just "physical") = return ProductPhysical
    makeProductType (Just "digital") = return ProductDigital
    makeProductType (Just _) = returnError ConversionFailed field "Unrecognized product type"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty product type"

instance QueryRunnerColumnDefault PGText ProductType where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For productId

instance FromField ProductId where
  fromField field mb_bytestring = ProductId <$> fromField field mb_bytestring

instance QueryRunnerColumnDefault PGInt4 ProductId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn
-- For TenantId
instance FromField TenantId where
  fromField field mb_bytestring = TenantId <$> fromField field mb_bytestring

instance QueryRunnerColumnDefault PGInt4 TenantId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- For Scientific we didn't have to implement instance of fromField
-- because it is already defined in postgresql-simple

instance QueryRunnerColumnDefault PGFloat8 Scientific where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

-- Default instance definitions for custom datatypes for converison to
-- PG types while writing into tables

-- For Tenant stuff

instance Default Constant TenantStatus (Column PGText) where
  def = Constant def'
    where
      def' :: TenantStatus -> (Column PGText)
      def' TenantStatusActive = pgStrictText "active"
      def' TenantStatusInActive = pgStrictText "inactive"
      def' TenantStatusNew = pgStrictText "new"

instance Default Constant TenantId (Maybe (Column PGInt4)) where
  def = Constant (\(TenantId x) -> Just $ pgInt4 x)

-- For Product stuff

instance Default Constant ProductType (Column PGText) where
  def = Constant def'
    where
      def' :: ProductType -> (Column PGText)
      def' ProductDigital = pgStrictText "digital"
      def' ProductPhysical = pgStrictText "physical"

instance Default Constant ProductId (Maybe (Column PGInt4)) where
  def = Constant (\(ProductId x) -> Just $ constant x)

instance Default Constant Scientific (Column PGFloat8) where
  def = Constant (pgDouble.toRealFloat)

instance Default Constant Scientific (Column (Nullable PGFloat8)) where
  def = Constant (toNullable.constant)

instance Default Constant Text (Column (Nullable PGText)) where
  def = Constant (toNullable.pgStrictText)

instance Default Constant UTCTime (Maybe (Column PGTimestamptz)) where
  def = Constant ((Just).pgUTCTime)

instance Default Constant TenantId (Column PGInt4) where
  def = Constant (\(TenantId x) -> constant x)

-- FromJSON/ToJSON instances for properties

instance FromJSON ProductProperties where
  parseJSON (Object v) = ProductProperties <$> v .: "color" <*> v .: "weight"
  parseJSON invalid = typeMismatch "Unrecognized format for product properties" invalid

instance ToJSON ProductProperties where
  toJSON ProductProperties {product_color = color, product_weight = weight} = object ["color" .= color, "weight" .= weight]

instance FromField ProductProperties where
  fromField field mb = do
    v <-  fromField field mb
    valueToProductProperties v
    where
      valueToProductProperties :: Value -> Conversion ProductProperties
      valueToProductProperties v = case fromJSON v of
        Success a -> return a
        Error err -> returnError ConversionFailed field "Cannot parse product properties"

instance QueryRunnerColumnDefault PGJsonb ProductProperties where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

instance Default Constant ProductProperties (Column PGJsonb) where
  def = Constant (\pp -> pgValueJSONB $ toJSON pp)

getProducts :: IO [Product]
getProducts = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ queryTable productTable

getTenants :: IO [Tenant]
getTenants = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ queryTable tenantTable

insertTenant :: IO ()
insertTenant = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runInsertManyReturning conn tenantTable [constant getTestTenant] (\x -> x) :: IO [Tenant]
  return ()

insertProduct :: IO ()
insertProduct = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  product <- getTestProduct
  runInsertManyReturning conn productTable [constant product] (\x -> x) :: IO [Product]
  return ()
  
getTestTenant :: TenantIncoming
getTestTenant = Tenant {
  tenant_id = (),
  tenant_name = "Tenant Bob",
  tenant_firstname = "Bobby",
  tenant_lastname = "Bob",
  tenant_email = "bob@gmail.com",
  tenant_phone = "2255",
  tenant_status = TenantStatusInActive,
  tenant_backofficedomain = "bob.com"
}

getTestProduct :: IO Product
getTestProduct = do
  time <- getCurrentTime
  let properties =  ProductProperties { product_color = "red", product_weight = "200gm"}
  return $ Product {
    product_id = (ProductId 5),
    product_created_at = time,
    product_updated_at = time,
    product_tenant_id = (TenantId 5),
    product_name = "snacks",
    product_description = Just "",
    product_url_slug = "",
    product_tags = ["tag1", "tag2"],
    product_currency = "INR",
    product_advertised_price = 30,
    product_comparison_price = 45,
    product_cost_price = Nothing,
    product_product_type = ProductPhysical,
    product_is_published = False,
    product_properties = properties
  }

main :: IO ()
main = do
  insertTenant
  insertProduct
  tenants <- getTenants
  products <- getProducts
  putStrLn $ show tenants
  putStrLn $ show products

-- Output
-- 
-- 
-- [Tenant {tenant_id = TenantId 1, tenant_name = "Tenant John", tenant_firstname = "John", tenant_lastname = "Honai", te
-- nant_email = "john@mail.com", tenant_phone = "2255", tenant_status = TenantStatusInActive, tenant_backofficedomain = "
-- jhonhonai.com"},Tenant {tenant_id = TenantId 5, tenant_name = "Tenant Bob", tenant_firstname = "Bobby", tenant_lastnam
-- e = "Bob", tenant_email = "bob@mail.com", tenant_phone = "2255", tenant_status = TenantStatusInActive, tenant_backoffi
-- cedomain = "bob.com"}]
-- [Product {product_id = ProductId 5, product_created_at = 2016-11-28 12:31:40.085634 UTC, product_updated_at = 2016-11-
-- 28 12:31:40.085634 UTC, product_tenant_id = TenantId 5, product_name = "snacks", product_description = Just "", produc
-- t_url_slug = "", product_tags = ["tag1","tag2"], product_currency = "INR", product_advertised_price = 30.0, product_co
-- mparison_price = 45.0, product_cost_price = Nothing, product_product_type = ProductPhysical, product_is_published = Fa
-- lse, product_properties = ProductProperties {product_color = "red", product_weight = "200gm"}}]

The type Conversion is a functor, so you can define instances for custom types in terms of existing FromField instances. For example, if you have a type that wraps an Int, like

data ProductId = ProductId Int

You can make a field parser instance for ProductId as follows

instance FromField ProductId where
  fromField field mb_bytestring = ProductId <$> fromField field mb_bytestring

While doing the above method, you have to make sure that the FromField instance that you are depending on can actually accept data from the underlying database column. This is relavant if you want to do this for enum types.

If you depend on the FromField instance of a String to read the data coming from an Enum field, it will error out because the FromField instance of String checks if the data is coming from a Varchar or Char field (using the first argument to the fromField function), and errors out if it is not.

Since the second argument to the fromField functon is a Maybe Bytestring, for a data type TenantStatus defined as

data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew

we could do the following

instance FromField TenantStatus where
  fromField field mb_bytestring = makeTenantStatus mb_bytestring
    where
    makeTenantStatus :: Maybe ByteString -> Conversion TenantStatus
    makeTenantStatus (Just "active") = return TenantStatusActive
    makeTenantStatus (Just "inactive") = return TenantStatusInActive
    makeTenantStatus (Just "new") = return TenantStatusNew
    makeTenantStatus (Just _) = returnError ConversionFailed field "Unrecognized tenant status"
    makeTenantStatus Nothing = returnError UnexpectedNull field "Empty tenant status"

With OverloadedStrings extension enabled, we could pattern match on Bystrings using normal String literals, and return the proper value. You can also see how we are handling unexpected values or a null coming from the column.