haskell + postgresql (postgresql-simple + resource-pool) (async)

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}

module Main where


import  Database.PostgreSQL.Simple   (Connection, ConnectInfo (..), Only (..),
                                      defaultConnectInfo, connect, query_, close)
import  Data.Pool                    (Pool, createPool, withResource, destroyAllResources)

--import  Control.Concurrent           (forkIO, threadDelay)
--import  Control.Monad                (forM)

import  Control.Concurrent           (threadDelay)
import  Control.Concurrent.Async     (replicateConcurrently)
import  Control.Monad                (replicateM)


{-

http://codeundreamedof.blogspot.com/2015/01/a-connection-pool-for-postgresql-in.html

CREATE TABLE films (
  id integer PRIMARY KEY,
  title varchar(20) NOT NULL
);

INSERT INTO films VALUES (1, 'Start Trek');
INSERT INTO films VALUES (2, 'Start Wars');
INSERT INTO films VALUES (3, 'Stardust');

-- postgresql-simple + resource-pool + async (instead forkIO)
add deps to .cabal
, postgresql-simple == 0.6.2
, resource-pool == 0.2.3.2
, async == 2.2.2
+
$ sudo apt install libpq-dev


-- we can use replicateM instead forM ,, add  {-# LANGUAGE BlockArguments #-}
  pool <- myPool
  let x = forkIO $ listMovies pool
  _ <- forM ([1..100 :: Int]) $ const x
-- change to
  pool <- myPool
  replicateM 100 do
    forkIO $ listMovies pool


todo : read
https://tech.fpcomplete.com/haskell/library/async
http://hackage.haskell.org/package/async-2.2.2/docs/Control-Concurrent-Async.html

-}


connectionInfo :: ConnectInfo
connectionInfo =
  defaultConnectInfo {
      connectHost = "localhost"
    , connectPort = 5432
    , connectUser = "postgres2"
    , connectPassword = "12345678"
    , connectDatabase = "test_postgres2"
  }


{-
And this is all we need to create a connection pool with createPool
-}

myPool :: IO (Pool Connection)
myPool = createPool (connect connectionInfo) close 1 10 10

{-
The first argument is a function which creates new connections.
The second argument is a function which closes the connections.
The rest of the arguments are as follows:
  subpools - the pool can have several independent pools, in our case it's 1,
  the maximum idle time of a connection (in seconds) before it is closed (in our case it's 10),
  the maximum amount of connections in the pool (in our case max. 10 connections).
-}


{-
We can test the connection pool with the following functions:
-}

printMovies :: Connection -> IO ()
printMovies conn = do
  x <- query_ conn "SELECT title FROM public.films"
  let films = map fromOnly (x :: [Only String])
  print films


listMovies :: Pool Connection -> IO ()
listMovies pool = do
  withResource pool printMovies


{-
We can define a simple function which prints the current number of connections in PostgreSQL:
-}

connectionCount :: IO ()
connectionCount = do
  conn <- connect connectionInfo
  x <- query_ conn "SELECT COUNT(*) FROM pg_stat_activity"
  let c = fromOnly . head $ (x :: [Only Integer])
  close conn
  print c


{-
And we can run these functions in multiple threads to check that the connection pool is set up properly:
-}


main :: IO ()
main = do
  pool <- myPool
  ----let x = forkIO $ listMovies pool
  ------forM [1..100] $ const x
  ------_ <- forM [1..100] $ const x
  ----_ <- forM ([1..100 :: Int]) $ const x
  --_ <- replicateM 100 do
  --  forkIO $ listMovies pool
  replicateConcurrently 100 do
    listMovies pool
  wait 5
  connectionCount
  wait 10
  connectionCount
  destroyAllResources pool
  where
    --wait s = threadDelay (10 ^ 6 * s)
    wait s = threadDelay $ 10 ^ 6 * s


{-
We get the following output:
"11"
"1"

Note:
We have 10 active connections + the connection in connectionCount through which we queried the connections on PostgreSQL.
After 10 seconds have elapsed we only have 1 open connection (the connectionCount's connection).
-}


main2 :: IO ()
main2 = do
  conn <- connect connectionInfo
  printMovies conn
  close conn

{-
ghci> main2
["Start Trek","Start Wars","Stardust"]
-}




{-
main :: IO ()
main = do
  putStrLn "hello world"
-}