Support functions to facilitate use of hasql

core-persistence-hasql/LICENSE

@@ -0,0 +1 @@
+../LICENSE

core-persistence-hasql/core-persistence-hasql.cabal

@@ -0,0 +1,50 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           core-persistence-hasql
+version:        0.0.1.0
+synopsis:       Interoperability with a Postgres datatabase via hasql
+description:    This is part of a library to help build command-line programs, both tools and
+                longer-running daemons.
+                .
+                This package in particular adds wrappers around __hasql__ to
+                facilitate reading and writing data to a Postgres database from programs
+                written using __core-program__ and __core-text__.
+category:       System
+stability:      experimental
+homepage:       https://github.com/aesiniath/unbeliever#readme
+bug-reports:    https://github.com/aesiniath/unbeliever/issues
+author:         Andrew Cowie <istathar@gmail.com>
+maintainer:     Andrew Cowie <istathar@gmail.com>
+copyright:      © 2021-2022 Athae Eredh Siniath and Others
+license:        MIT
+license-file:   LICENSE
+build-type:     Simple
+tested-with:
+    GHC == 8.10.7
+
+source-repository head
+  type: git
+  location: https://github.com/aesiniath/unbeliever
+
+library
+  exposed-modules:
+      Core.Persistence.Hasql
+  hs-source-dirs:
+      lib
+  ghc-options: -Wall -Wwarn -fwarn-tabs
+  build-depends:
+      base >=4.11 && <5
+    , bytestring
+    , core-data
+    , core-program
+    , core-telemetry
+    , core-text
+    , ghc-prim
+    , hasql
+    , hasql-pool
+    , vector
+  default-language: Haskell2010

core-persistence-hasql/lib/Core/Persistence/Hasql.hs

@@ -0,0 +1,163 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- |
+Reading and writing data to and from a Postgres database.
+
+This module simply contains conveniences for using the most excellent
+__hasql__ library in concert with the rest of the packages in
+this collection.
+-}
+module Core.Persistence.Hasql
+    ( performQuerySingleton
+    , performQueryVector
+    , performQueryMaybe
+    ) where
+
+import Core.Program.Context
+import Core.Program.Execute
+import Core.Program.Logging
+import Core.System.Base
+import Core.Telemetry.Observability
+import Core.Text.Rope
+import Data.Vector (Vector, toList)
+import GHC.Tuple (Solo (Solo), getSolo)
+import Hasql.Pool (Pool, UsageError (AcquisitionTimeoutUsageError, ConnectionUsageError, SessionUsageError), use)
+import Hasql.Session (QueryError (QueryError), sql, statement)
+import Hasql.Statement (Statement)
+import System.Timeout qualified as Base (timeout)
+
+{- |
+In the event of a problem connecting to the database or executing the query
+this exception will be thrown.
+-}
+data DatabaseFailure
+    = DatabaseConnectionFailed Rope
+    | DatabaseConnectionPool
+    | DatabaseQueryFailed Rope
+    | DatabaseQueryTimeout
+    deriving (Show)
+
+instance Exception DatabaseFailure
+
+{- |
+Indicate that the program's top-level application state type contains a
+connection pool. This is used (and shared) by all the database connections
+being made by this helper library.
+-}
+class Database δ where
+    connectionPoolFrom :: δ -> Pool
+
+--
+-- We need to ensure that database connections are aborted if they run too
+-- long; otherwise huge database CPU resources are consumed for no benefit to
+-- the end user. There are three magic numbers related to timeouts. Not
+-- visible here is the default 60 second timeout that e.g. Amazaon Application
+-- Load Balancers enforce on HTTP connections. We thus choose a slightly
+-- shorter "statement timeout" of 57 seconds after which the databse
+-- connection is aborted. Finally, just within that at 55 seconds is an I/O
+-- timeout on the Haskell side which is done explicitly so that we can
+-- [attempt to] kill the request and more importantly throw an appropriate
+-- error (so you can in turn return an appropriate HTTP status code, i.e.
+-- 524 A Timeout Occurred so that it's overtly visible within your outer
+-- monitoring).
+--
+
+performQueryActual
+    :: Database δ
+    => Functor f
+    => Foldable f
+    => Rope
+    -> (result -> α)
+    -> params
+    -> Statement params (f result)
+    -> Program δ (f α)
+performQueryActual label f values query = do
+    encloseSpan label $ do
+        state <- getApplicationState
+        let pool = connectionPoolFrom state
+
+        result <- liftIO $ do
+            Base.timeout (55 * 1000000) $ do
+                use
+                    pool
+                    ( do
+                        sql "SET statement_timeout = '57s';"
+                        statement values query
+                    )
+
+        case result of
+            Nothing -> do
+                throwTimeout
+            Just (Left problem) -> do
+                throwErrors label problem
+            Just (Right rows) -> do
+                telemetry
+                    [ metric "result_count" (length rows)
+                    ]
+                pure (fmap f rows)
+
+throwErrors :: Rope -> UsageError -> Program δ α
+throwErrors message result = do
+    case result of
+        ConnectionUsageError connectionError -> do
+            warn message
+
+            telemetry
+                [ metric "error" ("Database connection problem: " <> intoRope (show connectionError))
+                ]
+            throw (DatabaseConnectionFailed message)
+        SessionUsageError (QueryError template parameters commandError) -> do
+            warn message
+            debugS "template" template
+            debugS "parameters" parameters
+
+            telemetry
+                [ metric "error" ("Database transaction failed: " <> intoRope (show commandError))
+                ]
+            throw (DatabaseQueryFailed message)
+        AcquisitionTimeoutUsageError -> do
+            let unable = "Unable to get pool connection"
+            critical unable
+
+            telemetry
+                [ metric "error" unable
+                ]
+            throw DatabaseConnectionPool
+
+throwTimeout :: Program δ α
+throwTimeout = do
+    let message = "Database query timeout"
+    warn message
+    telemetry
+        [ metric "error" message
+        ]
+    throw DatabaseQueryTimeout
+
+performQuerySingleton
+    :: Database δ
+    => Rope
+    -> (result -> α)
+    -> params
+    -> Statement params result
+    -> Program δ α
+performQuerySingleton label f values query = performQueryActual label f values (fmap Solo query) >>= pure . getSolo
+
+performQueryVector
+    :: Database δ
+    => Rope
+    -> (result -> α)
+    -> params
+    -> Statement params (Vector result)
+    -> Program δ [α]
+performQueryVector label f values query = performQueryActual label f values query >>= pure . toList
+
+performQueryMaybe
+    :: Database δ
+    => Rope
+    -> (result -> α)
+    -> params
+    -> Statement params (Maybe result)
+    -> Program δ (Maybe α)
+performQueryMaybe label f values query = performQueryActual label f values query

core-persistence-hasql/package.yaml

@@ -0,0 +1,40 @@
+name: core-persistence-hasql
+version: 0.0.1.0
+synopsis: Interoperability with a Postgres datatabase via hasql
+description: |
+  This is part of a library to help build command-line programs, both tools and
+  longer-running daemons.
+
+  This package in particular adds wrappers around __hasql__ to
+  facilitate reading and writing data to a Postgres database from programs
+  written using __core-program__ and __core-text__.
+
+stability: experimental
+license: MIT
+license-file: LICENSE
+author: Andrew Cowie <istathar@gmail.com>
+maintainer: Andrew Cowie <istathar@gmail.com>
+copyright: © 2021-2022 Athae Eredh Siniath and Others
+tested-with: GHC == 8.10.7
+category: System
+ghc-options: -Wall -Wwarn -fwarn-tabs
+github: aesiniath/unbeliever
+
+dependencies:
+ - base >= 4.11 && < 5
+ - bytestring
+ - core-text
+ - core-data
+ - core-program
+ - core-telemetry
+ - ghc-prim
+ - hasql
+ - hasql-pool
+ - vector
+
+library:
+  dependencies: []
+  source-dirs: lib
+  exposed-modules:
+   - Core.Persistence.Hasql
+  other-modules: []

stack.yaml

@@ -4,6 +4,7 @@ packages:
  - ./core-data
  - ./core-effect-effectful
  - ./core-text
+ - ./core-persistence-hasql
  - ./core-program
  - ./core-telemetry
  - ./core-webserver-servant