Merge pull request #203 from tuomohopia/dev

Added a skeleton benchmark suite + mockup queries

squeal-postgresql/benchmarks/Main.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- Don't define 'module Main where' here
+-- or otherwise 'stack bench' won't work.
+
+import           Squeal.PostgreSQL       hiding ( defaultMain )
+import           Criterion.Main
+import           GHC.Generics
+import qualified Generics.SOP                  as SOP
+import           Test.QuickCheck
+-- Project imports
+import           Schema
+import           Queries
+
+main = defaultMain
+  [ bgroup
+      "Render Queries"
+      [ bench "createUser: weak head normal form" $ whnf renderSQL createUser
+      , bench "createUser: normal form" $ nf renderSQL createUser
+      , bench "userDetails: weak head normal form" $ whnf renderSQL userDetails
+      , bench "userDetails: normal form" $ nf renderSQL userDetails
+      , bench "insertDeviceDetails: weak head normal form"
+        $ whnf renderSQL insertDeviceDetails
+      , bench "insertDeviceDetails: normal form"
+        $ nf renderSQL insertDeviceDetails
+      ]
+  ]
+
+{- 
+To benchmark actual IO actions like supplying parameters to a query,
+we would generate samples via QuickCheck like this:
+
+```
+d :: [InsertUser] <- sample' arbitrary
+```
+
+Then start testing those generated values with `manipulateParams`.
+-}

squeal-postgresql/benchmarks/README.md

@@ -0,0 +1,9 @@
+# Microbenchark suite for Squeal
+> Benchmarking & profiling query rendering performance
+
+## Running
+
+Run benchmark suite with:
+```
+stack bench
+```

squeal-postgresql/benchmarks/lib/Queries.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass                #-}
+{-# LANGUAGE DerivingStrategies                #-}
+
+module Queries where
+
+import           Squeal.PostgreSQL
+import           GHC.Generics            hiding ( from )
+import qualified Generics.SOP                  as SOP
+import           Data.Text                      ( Text )
+import           Data.Int                       ( Int16
+                                                , Int64
+                                                )
+import           Data.Time                      ( UTCTime(..)
+                                                , fromGregorian
+                                                , secondsToDiffTime
+                                                )
+import           Test.QuickCheck                ( Arbitrary(..)
+                                                , PrintableString(..)
+                                                , listOf
+                                                , arbitraryPrintableChar
+                                                )
+import           Generic.Random                 ( genericArbitrarySingle )
+-- Import Orphan instances
+import           Test.QuickCheck.Instances      ( )
+-- Project imports
+import           Schema
+
+
+-- Types
+
+type UserId = Int64
+-- Insert user
+data InsertUser = InsertUser
+  { userEmail     :: Text
+  , userPassword  :: Text
+  , userFirstName :: Maybe Text
+  , userBirthyear :: Maybe Int16
+  , timeNow       :: UTCTime
+  }
+  deriving (Show, Generic)
+instance SOP.Generic InsertUser
+instance SOP.HasDatatypeInfo InsertUser
+-- Arbitrary instances for producing values with quickcheck
+instance Arbitrary InsertUser where
+  arbitrary = genericArbitrarySingle
+
+utcTime :: UTCTime
+utcTime = UTCTime (fromGregorian 2019 7 4) (secondsToDiffTime 5800)
+
+sampleInsertUser :: InsertUser
+sampleInsertUser = InsertUser { userEmail     = "[email protected]"
+                              , userPassword  = "MySecretPassword"
+                              , userFirstName = Just "Mark"
+                              , userBirthyear = Just 1980
+                              , timeNow       = utcTime
+                              }
+
+data APIDBUser_ = APIDBUser_
+  { userId     :: UserId
+  , email      :: Text
+  , first_name :: Maybe Text
+  , birthyear  :: Maybe Int16
+  }
+  deriving (Show, Generic)
+instance SOP.Generic APIDBUser_
+instance SOP.HasDatatypeInfo APIDBUser_
+-- Arbitrary instances for producing values with quickcheck
+instance Arbitrary APIDBUser_ where
+  arbitrary = genericArbitrarySingle
+
+data Row4 a b c d = Row4
+  { col1 :: a
+  , col2 :: b
+  , col3 :: c
+  , col4 :: d
+  }
+  deriving stock Generic
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+
+-- (UserId, Token, OS)
+type DeviceDetailsRow = Row4 UserId Text (Enumerated DeviceOS) UTCTime
+
+-- Queries
+
+createUser :: Manipulation_ Schemas InsertUser APIDBUser_
+createUser = insertInto
+  #users
+  (Values_
+    (    Default
+    `as` #id
+    :*   Set (param @1)
+    `as` #email
+    :*   Set (param @2)
+    `as` #password
+    :*   Set (param @3)
+    `as` #first_name
+    :*   Set (param @4 & cast int2)
+    `as` #birthyear
+    :*   Set (param @5)
+    `as` #inserted_at
+    :*   Set (param @5)
+    `as` #updated_at
+    )
+  )
+  OnConflictDoRaise
+  (Returning_
+    (    #id
+    `as` #userId
+    :*   #email
+    `as` #email
+    :*   #first_name
+    `as` #first_name
+    :*   #birthyear
+    `as` #birthyear
+    )
+  )
+
+userDetails :: Query_ Schemas (Only UserId) APIDBUser_
+userDetails = select_
+  (    #id
+  `as` #userId
+  :*   #email
+  `as` #email
+  :*   #first_name
+  `as` #first_name
+  :*   #birthyear
+  `as` #birthyear
+  )
+  (from (table #users) & where_ (#id .== (param @1 & cast int8)))
+
+insertDeviceDetails :: Manipulation_ Schemas DeviceDetailsRow ()
+insertDeviceDetails = insertInto
+  #user_devices
+  (Values_
+    (    Default
+    `as` #id
+    :*   Set (param @1)
+    `as` #user_id
+    :*   Set (param @2)
+    `as` #token
+    :*   Set (parameter @3 (typedef #device_os))
+    `as` #os
+    :*   Set (param @4)
+    `as` #inserted_at
+    :*   Set (param @4)
+    `as` #updated_at
+    )
+  )
+  OnConflictDoRaise
+  (Returning_ Nil)

squeal-postgresql/benchmarks/lib/Schema.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Schema where
+
+import           Squeal.PostgreSQL
+import           GHC.Generics
+import qualified Generics.SOP                  as SOP
+
+
+-- Type
+
+data DeviceOS = Android | IOS
+    deriving (Show, Read, Eq, Generic)
+-- DeviceOS is converted to PG Enum type
+instance SOP.Generic DeviceOS
+instance SOP.HasDatatypeInfo DeviceOS
+
+-- Defined extra types for the database
+-- Operating system enum
+type PGDeviceOS = PG (Enumerated DeviceOS)
+type DeviceOSType = 'Typedef PGDeviceOS
+
+-- SCHEMA
+
+-- | Helper: Joining timestamps to every table from here
+type TimestampColumns = '[
+  "inserted_at" ::: 'NoDef :=> 'NotNull 'PGtimestamptz
+  , "updated_at" ::: 'NoDef :=> 'NotNull 'PGtimestamptz
+  ]
+
+-- Users
+
+type UsersColumns = '[
+    "id"   :::   'Def :=> 'NotNull 'PGint8
+    , "email" ::: 'NoDef :=> 'NotNull 'PGtext
+    , "password" ::: 'NoDef :=> 'NotNull 'PGtext
+    , "first_name" ::: 'NoDef :=> 'Null 'PGtext
+    , "birthyear" ::: 'NoDef :=> 'Null 'PGint2
+    ]
+
+type UsersConstraints = '[
+    "pk_users" ::: 'PrimaryKey '["id"]
+    , "email" ::: 'Unique '["email"]
+    ]
+
+type UsersTable = 'Table (UsersConstraints :=> Join UsersColumns TimestampColumns)
+
+-- User devices
+type UserDevicesColumns = '[
+  "id" ::: 'Def :=> 'NotNull 'PGint8 -- ID as PK because user might have many same OS devices
+  , "user_id" ::: 'NoDef :=> 'NotNull 'PGint8
+  , "token" ::: 'NoDef :=> 'NotNull 'PGtext
+  , "os" ::: 'NoDef :=> 'NotNull PGDeviceOS
+  ]
+
+type UserDevicesConstraints = '[
+  "pk_user_devices" ::: 'PrimaryKey '["id"]
+  , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
+  , "token" ::: 'Unique '["token"]
+  ]
+
+type UserDevicesTable = 'Table (UserDevicesConstraints :=> Join UserDevicesColumns TimestampColumns)
+
+-- Schema
+-- Make sure to put types before tables, otherwise won't compile
+type Schema = '[
+  -- Enum types:
+    "device_os" ::: DeviceOSType
+  -- Composite types:
+  , "users" ::: UsersTable
+  , "user_devices" ::: UserDevicesTable
+  ]
+
+type Schemas = '["public" ::: Schema]

squeal-postgresql/squeal-postgresql.cabal

@@ -144,6 +144,34 @@ test-suite spec
     , text >= 1.2.2.2
     , vector >= 0.12.0.1
 
+benchmark benchmarks
+  type: exitcode-stdio-1.0
+  hs-source-dirs: benchmarks, benchmarks/lib
+  main-is: Main.hs
+  other-modules: Schema, Queries
+  default-language: Haskell2010
+  ghc-options:
+    -O2
+    -threaded
+    "-with-rtsopts=-N"
+    -rtsopts
+    -funbox-strict-fields
+  build-depends:
+      base >= 4.10.0.0
+    , bytestring >= 0.10.8.2
+    , text >= 1.2.2.2
+    , generics-sop >= 0.3.1.0
+    , hedgehog >= 1.0
+    , mtl >= 2.2.2
+    , scientific >= 0.3.5.3
+    , squeal-postgresql
+    , time >= 1.8.0.2
+    , with-utf8 >= 1.0
+    , criterion
+    , QuickCheck
+    , quickcheck-instances
+    , generic-random
+
 executable example
   default-language: Haskell2010
   hs-source-dirs: exe