Reset to hasql-pool-0.8.0.2 upstream

CHANGELOG.md

@@ -1,7 +1,18 @@
-# Unreleased (PostgREST fork)
+# 0.8.0.2
 
-Added support for timing out resource acquisition ([PR #](https://github.com/PostgREST/hasql-pool/pull/3)).
-Added support for flushing the pool without destroying it ([PR #2](https://github.com/PostgREST/hasql-pool/pull/2)).
+Fixed Windows build.
+
+# 0.8
+
+`release` became reusable. You can use it to destroy the whole pool (same as before), but now also you can use it to reset the connections.
+
+Acquisition timeout added.
+
+Breaking changes in API:
+
+- Removed `PoolIsReleasedUsageError`
+- `acquire` extended with the acquisition timeout parameter
+- `acquireDynamically` extended with the acquisition timeout parameter
 
 # 0.7.2
 

hasql-pool.cabal

@@ -1,76 +1,53 @@
-name:
-  hasql-pool
-version:
-  0.7.2
-category:
-  Hasql, Database, PostgreSQL
-synopsis:
-  A pool of connections for Hasql
-homepage:
-  https://github.com/nikita-volkov/hasql-pool 
-bug-reports:
-  https://github.com/nikita-volkov/hasql-pool/issues 
-author:
-  Nikita Volkov <[email protected]>
-maintainer:
-  Nikita Volkov <[email protected]>
-copyright:
-  (c) 2015, Nikita Volkov
-license:
-  MIT
-license-file:
-  LICENSE
-build-type:
-  Simple
-cabal-version:
-  >=1.10
-extra-source-files:
-  CHANGELOG.md
+cabal-version: 3.0
 
+name: hasql-pool
+version: 0.8.0.2
+
+category: Hasql, Database, PostgreSQL
+synopsis: Pool of connections for Hasql
+homepage: https://github.com/nikita-volkov/hasql-pool
+bug-reports: https://github.com/nikita-volkov/hasql-pool/issues
+author: Nikita Volkov <[email protected]>
+maintainer: Nikita Volkov <[email protected]>
+copyright: (c) 2015, Nikita Volkov
+license: MIT
+license-file: LICENSE
+extra-source-files: CHANGELOG.md
 
 source-repository head
-  type:
-    git
-  location:
-    git://github.com/nikita-volkov/hasql-pool.git
+  type: git
+  location: git://github.com/nikita-volkov/hasql-pool.git
 
+common base-settings
+  default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DerivingVia, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language: Haskell2010
 
 library
-  hs-source-dirs:
-    library
-  ghc-options:
-  default-extensions:
-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
-  default-language:
-    Haskell2010
+  import: base-settings
+  hs-source-dirs: library
   exposed-modules:
     Hasql.Pool
   other-modules:
     Hasql.Pool.Prelude
+    Hasql.Pool.TimeExtras.IO
+    Hasql.Pool.TimeExtras.Conversions
   build-depends:
     base >=4.11 && <5,
-    hasql >=1.3 && <1.6,
+    hasql >=1.6.0.1 && <1.7,
     stm >=2.5 && <3,
     time >=1.5 && <2,
-    transformers >=0.5 && <0.7
-
+    transformers >=0.5 && <0.7,
 
 test-suite test
-  type:
-    exitcode-stdio-1.0
-  hs-source-dirs:
-    test
-  main-is:
-    Main.hs
-  default-extensions:
-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
-  default-language:
-    Haskell2010
+  import: base-settings
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Main.hs
   ghc-options: -threaded
   build-depends:
+    async >=2.2 && <3,
     hasql,
     hasql-pool,
-    async,
     hspec >=2.6 && <3,
     rerebase >=1.15 && <2,
-    stm >=2.5 && <3
+    stm >=2.5 && <3,

library/Hasql/Pool.hs

@@ -3,7 +3,6 @@ module Hasql.Pool
     Pool,
     acquire,
     acquireDynamically,
-    flush,
     release,
     use,
 
@@ -18,7 +17,7 @@ import Hasql.Pool.Prelude
 import Hasql.Session (Session)
 import qualified Hasql.Session as Session
 
--- | A pool of connections to DB.
+-- | Pool of connections to DB.
 data Pool = Pool
   { -- | Connection settings.
     poolFetchConnectionSettings :: IO Connection.Settings,
@@ -28,66 +27,62 @@ data Pool = Pool
     poolConnectionQueue :: TQueue Connection,
     -- | Remaining capacity.
     -- The pool size limits the sum of poolCapacity, the length
-    -- of length poolConnectionQueue and the number of in-flight
+    -- of poolConnectionQueue and the number of in-flight
     -- connections.
     poolCapacity :: TVar Int,
-    -- | Liveness state of the current generation.
-    -- The pool as a whole is alive if the current generation is alive,
-    -- while a connection is returned to the pool if the generation it
-    -- was acquired in is still alive.
-    poolAlive :: TVar (TVar Bool)
+    -- | Whether to return a connection to the pool.
+    poolReuse :: TVar (TVar Bool)
   }
 
--- | Given the pool-size and connection settings create a connection-pool.
+-- | Create a connection-pool.
 --
 -- No connections actually get established by this function. It is delegated
 -- to 'use'.
-acquire :: Int -> Maybe Int -> Connection.Settings -> IO Pool
+acquire ::
+  -- | Pool size.
+  Int ->
+  -- | Connection acquisition timeout.
+  Maybe Int ->
+  -- | Connection settings.
+  Connection.Settings ->
+  IO Pool
 acquire poolSize timeout connectionSettings =
   acquireDynamically poolSize timeout (pure connectionSettings)
 
--- | Given the pool-size and connection settings constructor action
--- create a connection-pool.
---
--- No connections actually get established by this function. It is delegated
--- to 'use'.
+-- | Create a connection-pool.
 --
 -- In difference to 'acquire' new settings get fetched each time a connection
 -- is created. This may be useful for some security models.
-acquireDynamically :: Int -> Maybe Int -> IO Connection.Settings -> IO Pool
+--
+-- No connections actually get established by this function. It is delegated
+-- to 'use'.
+acquireDynamically ::
+  -- | Pool size.
+  Int ->
+  -- | Connection acquisition timeout.
+  Maybe Int ->
+  -- | Action fetching connection settings.
+  IO Connection.Settings ->
+  IO Pool
 acquireDynamically poolSize timeout fetchConnectionSettings = do
   Pool fetchConnectionSettings timeout
     <$> newTQueueIO
     <*> newTVarIO poolSize
     <*> (newTVarIO =<< newTVarIO True)
 
--- | Release all the idle connections in the pool and mark the pool as dead.
--- In-use connections will survive this and be closed once they would be returned
--- to the pool.
+-- | Release all the idle connections in the pool, and mark the in-use connections
+-- to be released on return. Any connections acquired after the call will be
+-- newly established.
 release :: Pool -> IO ()
-release Pool {..} = do
-  connections <- atomically $ do
-    alive <- readTVar poolAlive
-    writeTVar alive False
-    flushTQueue poolConnectionQueue
-  forM_ connections Connection.release
-
--- | Flush the pool, so that using the pool doesn't reuse any connection from
--- before the call. Release all the idle connections in the pool, and mark
--- in-use connections to be closed once they would be returned.
-flush :: Pool -> IO ()
-flush Pool {..} =
+release Pool {..} =
   join . atomically $ do
-    prevAlive <- readTVar poolAlive
-    alive <- readTVar prevAlive
-    if alive
-      then do
-        writeTVar prevAlive False
-        writeTVar poolAlive =<< newTVar True
-        conns <- flushTQueue poolConnectionQueue
-        modifyTVar' poolCapacity (+ (length conns))
-        return $ forM_ conns Connection.release
-      else return (return ())
+    prevReuse <- readTVar poolReuse
+    writeTVar prevReuse False
+    newReuse <- newTVar True
+    writeTVar poolReuse newReuse
+    conns <- flushTQueue poolConnectionQueue
+    modifyTVar' poolCapacity (+ (length conns))
+    return $ forM_ conns Connection.release
 
 -- | Use a connection from the pool to run a session and return the connection
 -- to the pool, when finished.
@@ -105,36 +100,32 @@ use Pool {..} sess = do
     Nothing ->
       return $ return False
   join . atomically $ do
-    aliveVar <- readTVar poolAlive
-    alive <- readTVar aliveVar
-    if alive
-      then do
-        asum
-          [ readTQueue poolConnectionQueue <&> onConn aliveVar,
-            do
-              capVal <- readTVar poolCapacity
-              if capVal > 0
-                then do
-                  writeTVar poolCapacity $! pred capVal
-                  return $ onNewConn aliveVar
-                else retry,
-            do
-              timedOut <- timeout
-              if timedOut
-                then return . return . Left $ AcquisitionTimeout
-                else retry
-          ]
-      else return . return . Left $ PoolIsReleasedUsageError
+    reuseVar <- readTVar poolReuse
+    asum
+      [ readTQueue poolConnectionQueue <&> onConn reuseVar,
+        do
+          capVal <- readTVar poolCapacity
+          if capVal > 0
+            then do
+              writeTVar poolCapacity $! pred capVal
+              return $ onNewConn reuseVar
+            else retry,
+        do
+          timedOut <- timeout
+          if timedOut
+            then return . return . Left $ AcquisitionTimeoutUsageError
+            else retry
+      ]
   where
-    onNewConn aliveVar = do
+    onNewConn reuseVar = do
       settings <- poolFetchConnectionSettings
       connRes <- Connection.acquire settings
       case connRes of
         Left connErr -> do
           atomically $ modifyTVar' poolCapacity succ
           return $ Left $ ConnectionUsageError connErr
-        Right conn -> onConn aliveVar conn
-    onConn aliveVar conn = do
+        Right conn -> onConn reuseVar conn
+    onConn reuseVar conn = do
       sessRes <- Session.run sess conn
       case sessRes of
         Left err -> case err of
@@ -150,8 +141,8 @@ use Pool {..} sess = do
       where
         returnConn =
           join . atomically $ do
-            alive <- readTVar aliveVar
-            if alive
+            reuse <- readTVar reuseVar
+            if reuse
               then writeTQueue poolConnectionQueue conn $> return ()
               else do
                 modifyTVar' poolCapacity succ
@@ -163,10 +154,8 @@ data UsageError
     ConnectionUsageError Connection.ConnectionError
   | -- | Session execution failed.
     SessionUsageError Session.QueryError
-  | -- | Attempt to use a pool, which has already been called 'release' upon.
-    PoolIsReleasedUsageError
   | -- | Timeout acquiring a connection.
-    AcquisitionTimeout
+    AcquisitionTimeoutUsageError
   deriving (Show, Eq)
 
 instance Exception UsageError

library/Hasql/Pool/Prelude.hs

@@ -1,6 +1,5 @@
 module Hasql.Pool.Prelude
   ( module Exports,
-    getMillisecondsSinceEpoch,
   )
 where
 
@@ -81,10 +80,3 @@ import Text.Printf as Exports (hPrintf, printf)
 import Text.Read as Exports (Read (..), readEither, readMaybe)
 import Unsafe.Coerce as Exports
 import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))
-
-getMillisecondsSinceEpoch :: IO Int
-getMillisecondsSinceEpoch =
-  fmap (fromIntegral . systemTimeToMicros) getSystemTime
-  where
-    systemTimeToMicros (MkSystemTime s ns) =
-      s * 1000 + fromIntegral (div ns 1000000)