using pool + concurrency

frameworks/Haskell/spock/src/Main.hs

@@ -7,7 +7,7 @@ import           Control.Concurrent.Async
 import           Control.Monad.IO.Class
 import           Data.Aeson                    hiding (json)
 import           Data.List                     (sort)
-import           Data.Maybe                    (fromMaybe)
+import           Data.Maybe                    (catMaybes, fromMaybe)
 import           Data.Pool
 import qualified Database.PostgreSQL.Simple    as PG
 import           GHC.Exts
@@ -91,11 +91,11 @@ test4 = do
 {-# INLINE test4 #-}
 
 -- | Test 5: Database Updates
-test5 :: ActionCtxT ctx (WebStateM PG.Connection b ()) a
-test5 = do
+test5 :: Pool PG.Connection -> ActionCtxT ctx (WebStateM PG.Connection b ()) a
+test5 pool = do
     queries <- getQueriesNumber
-    worlds <- runQuery $ fetchRandomWorldsAsync queries
-    updatedWorlds <- runQuery $ updateWorldsRandomAsync worlds
+    worlds <- liftIO $ mapConcurrently (const (withResource pool getRandomWorld)) [1..queries]
+    updatedWorlds <- liftIO $ mapConcurrently (withResource pool . updateWorldRandom) (catMaybes worlds)
     setHeader "Content-Type" "application/json"
     lazyBytes $ encode updatedWorlds
 {-# INLINE test5 #-}
@@ -118,5 +118,5 @@ main = do
         get "db"          test2
         get "queries"   $ test3 pool
         get "fortune"     test4
-        get "updates"     test5
+        get "updates"   $ test5 pool
         get "plaintext"   test6

frameworks/Haskell/spock/src/Models/World.hs

@@ -5,11 +5,9 @@ module Models.World
     ( World(..)
     , fetchWorldById
     , getRandomWorld
-    , fetchRandomWorldsAsync
-    , updateWorldsRandomAsync
+    , updateWorldRandom
     ) where
 
-import           Control.Concurrent.Async
 import           Data.Aeson
 import           Data.Maybe
 import           Data.Monoid                        ((<>))
@@ -54,24 +52,10 @@ getRandomWorld c = do
     fetchWorldById i c
 {-# INLINE getRandomWorld #-}
 
--- | Get n random Worlds in a concurrent way.
-fetchRandomWorldsAsync :: Int -> PG.Connection -> IO [World]
-fetchRandomWorldsAsync n c = do
-    maybes <- mapConcurrently (\_ -> getRandomWorld c) [1..n]
-    return $ catMaybes maybes
-{-# INLINE fetchRandomWorldsAsync #-}
-
 -- | Update a World with a random number
-updateWorldRandom :: PG.Connection -> World -> IO World
-updateWorldRandom c (World _id _) = do
+updateWorldRandom :: World -> PG.Connection -> IO World
+updateWorldRandom (World _id _) c = do
     i <- randomRIO (1, 10000)
     _ <- PG.execute c "UPDATE World SET randomNumber = ? WHERE id = ?" (i, _id)
     return $ World _id i
 {-# INLINE updateWorldRandom #-}
-
--- | Update a bunch of Worlds in a concurrent way.
-updateWorldsRandomAsync :: [World] -> PG.Connection -> IO [World]
-updateWorldsRandomAsync ws c = do
-    _ <- PG.execute_ c "SET synchronous_commit TO OFF"
-    mapConcurrently (updateWorldRandom c) ws
-{-# INLINE updateWorldsRandomAsync #-}