#389 jsonb

.travis.yml

@@ -53,8 +53,8 @@ jobs:
         - git remote set-url origin [email protected]:aelve/guide.git
       script:
         # Build
-        - stack --no-terminal build --test --no-run-tests --dependencies-only
-        - stack --no-terminal build --test --no-run-tests
+        - stack --no-terminal build --test --no-run-tests --bench --no-run-benchmarks --dependencies-only
+        - stack --no-terminal build --test --no-run-tests --bench --no-run-benchmarks
         # Regenerate Swagger and push to the same branch, even if the branch
         # is already ahead (which may happen if the previous build in the
         # pipeline also pushed to it)
@@ -87,7 +87,7 @@ jobs:
         # from scratch, then we build haddocks and count the lines for
         # "missing documentation".
         - stack --no-terminal exec -- ghc-pkg unregister guide
-        - stack --no-terminal build --test --no-run-tests --haddock --no-haddock-deps --haddock-arguments='--no-warnings' 2> haddock.log
+        - stack --no-terminal build --test --no-run-tests --bench --no-run-benchmarks --haddock --no-haddock-deps --haddock-arguments='--no-warnings' 2> haddock.log
         - export undocumented=$(awk '/\(src\// {count++} END{print count}' haddock.log)
         - |
           echo "Undocumented definitions: $undocumented"
@@ -106,7 +106,7 @@ jobs:
         # travis_retry works around https://github.com/commercialhaskell/stack/issues/4888
         - travis_retry stack setup
         # Install chromedriver
-        - wget https://chromedriver.storage.googleapis.com/76.0.3809.68/chromedriver_linux64.zip
+        - wget https://chromedriver.storage.googleapis.com/76.0.3809.126/chromedriver_linux64.zip
         - unzip chromedriver_linux64.zip
         - chmod +x chromedriver
         - sudo mv -f chromedriver /usr/local/share/chromedriver

README.md

@@ -5,3 +5,22 @@
 The production version is running at [guide.aelve.com](https://guide.aelve.com). The new frontend is being developed at [staging.guide.aelve.com](https://staging.guide.aelve.com).
 
 Installation instructions and the explanation of config variables (in `config.json`) are here: [INSTALL.md](INSTALL.md).
+
+## Benchmarking
+
+Start Postgres and create an empty database called `guide-bench`. An example
+with Docker:
+
+```
+docker run --name guide-db -e POSTGRES_PASSWORD=3 -e POSTGRES_DB=guide-bench -p 5432:5432 -d postgres
+```
+
+Build and run benchmarks:
+
+```
+stack bench
+```
+
+If you have been building with `--fast` previously, or using `make`, Stack
+will detect that Guide has to be recompiled with `-O` and do it
+automatically.

back/benchmarks/Main.hs

@@ -0,0 +1,91 @@
+-- | Benchmarks to check time of jsonb query.
+module Main
+       (
+         main
+       ) where
+
+import Imports
+
+import Gauge
+import Hasql.Transaction.Sessions (Mode (..))
+import Hasql.Connection (Connection)
+import qualified Data.Set as Set
+
+import Guide.Database.Schema (setupDatabase)
+import Guide.Database.Queries.Update
+import Guide.Database.Queries.Select
+import Guide.Database.Queries.Insert
+import Guide.Database.Queries.Delete
+import Guide.Types.Core
+import Guide.Database.Connection
+import Guide.Markdown (toMarkdownBlock, toMarkdownTree)
+
+
+-- | See readme for instruction.
+main :: IO ()
+main = do
+  putStrLn "Connecting to database guide-bench"
+  conn <- connect (#database "guide-bench")
+  putStrLn "Initializing database"
+  setupDatabase conn
+  time <- getCurrentTime
+  runTransactionExceptT conn Write $
+    insertCategoryWithCategory (#archived False) $ category time
+  defaultMain [databaseBenchmark conn]
+  runTransactionExceptT conn Write $ deleteCategory "categoryUid1"
+
+databaseBenchmark :: Connection -> Benchmark
+databaseBenchmark conn =
+  let update :: Category -> Category
+      update =  _categoryTitle <>~ " +"
+  in bgroup "Database"
+      [ bench "select" $ nfIO $
+          runTransactionExceptT conn Read $ selectCategory "categoryUid1"
+      , bench "update" $ nfIO $
+          runTransactionExceptT conn Write $ updateCategory "categoryUid1" update
+      ]
+
+category :: UTCTime -> Category
+category time = Category
+  { categoryUid = "categoryUid1"
+  , categoryTitle = "catTitle1"
+  , categoryCreated =  time
+  , categoryGroup = "group1"
+  , categoryStatus = CategoryStub
+  , categoryNotes = toMarkdownBlock "notes"
+  , categoryItems = [item time]
+  , categoryItemsDeleted = []
+  , categoryEnabledSections = Set.fromList []
+  }
+
+item :: UTCTime -> Item
+item time = Item
+  { itemUid = "itemUid1234"
+  , itemName = "title"
+  , itemCreated = time
+  , itemHackage = Just "hello"
+  , itemSummary = toMarkdownBlock "summary"
+  , itemPros = []
+  , itemProsDeleted = []
+  , itemCons = []
+  , itemConsDeleted = []
+  , itemEcosystem = toMarkdownBlock "eco"
+  , itemNotes = toMarkdownTree "" "notes"
+  , itemLink = Just "google.ru"
+  }
+
+{-
+benchmarked Database/select
+time                 843.9 μs   (812.4 μs .. 879.6 μs)
+                     0.987 R²   (0.978 R² .. 0.993 R²)
+mean                 846.1 μs   (823.0 μs .. 864.6 μs)
+std dev              69.75 μs   (58.01 μs .. 87.73 μs)
+variance introduced by outliers: 53% (severely inflated)
+
+benchmarked Database/update
+time                 2.435 ms   (2.388 ms .. 2.480 ms)
+                     0.995 R²   (0.992 R² .. 0.998 R²)
+mean                 2.358 ms   (2.313 ms .. 2.396 ms)
+std dev              148.0 μs   (117.9 μs .. 194.6 μs)
+variance introduced by outliers: 39% (moderately inflated)
+-}

back/package.yaml

@@ -197,3 +197,17 @@ tests:
     - temporary
     - webdriver
     - yaml
+
+benchmarks:
+  benchmarks:
+    main: Main.hs
+    source-dirs: benchmarks
+    dependencies:
+      - base <5
+      - containers
+      - gauge
+      - guide
+      - hasql
+      - hasql-transaction
+      - random
+      - time

back/src/Guide/Database/Connection.hs

@@ -8,7 +8,7 @@ module Guide.Database.Connection
        ) where
 
 import Imports
-import Hasql.Connection (Connection, Settings)
+import Hasql.Connection (Connection)
 import Hasql.Session (Session)
 import Hasql.Transaction (Transaction)
 import Hasql.Transaction.Sessions (Mode, IsolationLevel(..))
@@ -23,17 +23,16 @@ import Guide.Database.Types (DatabaseError)
 -- | Create a database connection (the destination is hard-coded for now).
 --
 -- Throws an 'error' if the connection could not be established.
-connect :: IO Connection
-connect = do
-  HC.acquire connectionSettings >>= \case
+connect
+  :: "database" :! ByteString
+  -> IO Connection
+connect (arg #database -> dbName) = do
+  let settings = HC.settings "localhost" 5432 dbUser dbPass dbName
+  HC.acquire settings >>= \case
     Left Nothing -> error "connect: unknown exception"
     Left (Just x) -> error ("connect: " ++ utf8ToString x)
     Right conn -> pure conn
 
--- | Connection settings
-connectionSettings :: Settings
-connectionSettings = HC.settings "localhost" 5432 dbUser dbPass dbName
-
 -- | Database user
 dbUser :: ByteString
 dbUser = "postgres"
@@ -42,10 +41,6 @@ dbUser = "postgres"
 dbPass :: ByteString
 dbPass = "3"
 
--- | Database name
-dbName :: ByteString
-dbName = "guide"
-
 ----------------------------------------------------------------------------
 -- Utilities
 ----------------------------------------------------------------------------