Make examples compile

examples/Catalog.hs

@@ -1,20 +1,18 @@
-{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards
-  , ScopedTypeVariables, TypeFamilies #-}
-{-# OPTIONS_GHC -Wall #-}
+module Catalog (catalog) where
 
 import Control.Arrow (second)
 import Control.Monad
 import Control.Monad.Base
 import Control.Monad.Catch
 import Data.Function
 import Data.Int
-import Data.Monoid
 import Data.Monoid.Utils
+import Data.Pool
+import Data.Text qualified as T
 import Database.PostgreSQL.PQTypes
 import Database.PostgreSQL.PQTypes.Internal.Utils (mread)
 import System.Console.Readline
 import System.Environment
-import qualified Data.ByteString.Char8 as BS
 
 -- | Generic 'putStrLn'.
 printLn :: MonadBase IO m => String -> m ()
@@ -25,7 +23,7 @@ getConnSettings :: IO ConnectionSettings
 getConnSettings = do
   args <- getArgs
   case args of
-    [conninfo] -> return def { csConnInfo = BS.pack conninfo }
+    [conninfo] -> return defaultConnectionSettings {csConnInfo = T.pack conninfo}
     _ -> do
       prog <- getProgName
       error $ "Usage:" <+> prog <+> "<connection info>"
@@ -34,10 +32,11 @@ getConnSettings = do
 
 -- | Representation of a book.
 data Book = Book
-  { bookID       :: Int64
-  , bookName     :: String
-  , bookYear     :: Int32
-  } deriving (Read, Show)
+  { bookID :: Int64
+  , bookName :: String
+  , bookYear :: Int32
+  }
+  deriving (Read, Show)
 
 -- | Intermediate representation of 'Book'.
 type instance CompositeRow Book = (Int64, String, Int32)
@@ -46,78 +45,87 @@ instance PQFormat Book where
   pqFormat = "%book_"
 
 instance CompositeFromSQL Book where
-  toComposite (bid, name, year) = Book {
-    bookID = bid
-  , bookName = name
-  , bookYear = year
-  }
+  toComposite (bid, name, year) =
+    Book
+      { bookID = bid
+      , bookName = name
+      , bookYear = year
+      }
 
 withCatalog :: ConnectionSettings -> IO () -> IO ()
-withCatalog cs = bracket_ createStructure dropStructure
+withCatalog settings = bracket_ createStructure dropStructure
   where
-    -- | Create needed tables and types.
-    createStructure = runDBT (simpleSource cs) def $ do
+    ConnectionSource cs = simpleSource settings
+
+    -- Create needed tables and types.
+    createStructure = runDBT cs defaultTransactionSettings $ do
       printLn "Creating tables..."
-      runSQL_ $ mconcat [
-          "CREATE TABLE authors_ ("
-        , "  id BIGSERIAL NOT NULL"
-        , ", name TEXT NOT NULL"
-        , ", PRIMARY KEY (id)"
-        , ")"
-        ]
-      runSQL_ $ mconcat [
-          "CREATE TABLE books_ ("
-        , "  id BIGSERIAL NOT NULL"
-        , ", name TEXT NOT NULL"
-        , ", year INTEGER NOT NULL"
-        , ", author_id BIGINT NOT NULL"
-        , ", PRIMARY KEY (id)"
-        , ", FOREIGN KEY (author_id) REFERENCES authors_ (id)"
-        , ")"
-        ]
-      runSQL_ $ mconcat [
-          "CREATE TYPE book_ AS ("
-        , "  id BIGINT"
-        , ", name TEXT"
-        , ", year INTEGER"
-        , ")"
-        ]
-    -- | Drop previously created database structures.
-    dropStructure = runDBT (simpleSource cs) def $ do
+      runSQL_ $
+        mconcat
+          [ "CREATE TABLE authors_ ("
+          , "  id BIGSERIAL NOT NULL"
+          , ", name TEXT NOT NULL"
+          , ", PRIMARY KEY (id)"
+          , ")"
+          ]
+      runSQL_ $
+        mconcat
+          [ "CREATE TABLE books_ ("
+          , "  id BIGSERIAL NOT NULL"
+          , ", name TEXT NOT NULL"
+          , ", year INTEGER NOT NULL"
+          , ", author_id BIGINT NOT NULL"
+          , ", PRIMARY KEY (id)"
+          , ", FOREIGN KEY (author_id) REFERENCES authors_ (id)"
+          , ")"
+          ]
+      runSQL_ $
+        mconcat
+          [ "CREATE TYPE book_ AS ("
+          , "  id BIGINT"
+          , ", name TEXT"
+          , ", year INTEGER"
+          , ")"
+          ]
+    -- Drop previously created database structures.
+    dropStructure = runDBT cs defaultTransactionSettings $ do
       printLn "Dropping tables..."
       runSQL_ "DROP TYPE book_"
       runSQL_ "DROP TABLE books_"
       runSQL_ "DROP TABLE authors_"
 
 ----------------------------------------
 
-processCommand :: ConnectionSource -> String -> IO ()
+processCommand :: ConnectionSourceM IO -> String -> IO ()
 processCommand cs cmd = case parse cmd of
-  -- | Display authors.
-  ("authors", "") -> runDBT cs def $ do
+  -- Display authors.
+  ("authors", "") -> runDBT cs defaultTransactionSettings $ do
     runSQL_ "SELECT * FROM authors_ ORDER BY name"
-    mapDB_ $ \(aid::Int64, name) -> printLn $ show aid <> ":" <+> name
-  -- | Display books.
-  ("books", "") -> runDBT cs def $ do
+    mapDB_ $ \(aid :: Int64, name) -> printLn $ show aid <> ":" <+> name
+  -- Display books.
+  ("books", "") -> runDBT cs defaultTransactionSettings $ do
     runSQL_ "SELECT a.name, ARRAY(SELECT (b.id, b.name, b.year)::book_ FROM books_ b WHERE b.author_id = a.id) FROM authors_ a ORDER BY a.name"
-    mapDB_ $ \(author, CompositeArray1 (books::[Book])) -> do
+    mapDB_ $ \(author, CompositeArray1 (books :: [Book])) -> do
       printLn $ author <> ":"
       forM_ books $ \book -> printLn $ "*" <+> show book
-  -- | Insert an author.
+  -- Insert an author.
   ("insert_author", mname) -> case mread mname of
-    Just (name::String) -> runDBT cs def . runQuery_ $
-      "INSERT INTO authors_ (name) VALUES (" <?> name <+> ")"
+    Just (name :: String) ->
+      runDBT cs defaultTransactionSettings . runQuery_ $
+        "INSERT INTO authors_ (name) VALUES (" <?> name <+> ")"
     Nothing -> printLn $ "Invalid name"
-  -- | Insert a book.
+  -- Insert a book.
   ("insert_book", mbook) -> case mread mbook of
-    Just record -> runDBT cs def . runQuery_ $ rawSQL
-      "INSERT INTO books_ (name, year, author_id) VALUES ($1, $2, $3)"
-      (record::(String, Int32, Int64))
+    Just record ->
+      runDBT cs defaultTransactionSettings . runQuery_ $
+        rawSQL
+          "INSERT INTO books_ (name, year, author_id) VALUES ($1, $2, $3)"
+          (record :: (String, Int32, Int64))
     Nothing -> printLn $ "Invalid book record"
-  -- | Handle unknown commands.
+  -- Handle unknown commands.
   _ -> printLn $ "Unknown command:" <+> cmd
   where
-    parse = second (drop 1) . break (==' ')
+    parse = second (drop 1) . break (== ' ')
 
 -- | Example chain of commands:
 --
@@ -131,14 +139,18 @@ processCommand cs cmd = case parse cmd of
 --
 -- If you want to check out exceptions in action,
 -- try inserting a book with invalid author id.
-main :: IO ()
-main = do
+catalog :: IO ()
+catalog = do
   cs <- getConnSettings
   withCatalog cs $ do
-    pool <- poolSource (cs { csComposites = ["book_"] }) 1 10 4
-    fix $ \next -> readline "> " >>= maybe (printLn "") (\cmd -> do
-      when (cmd /= "quit") $ do
-        processCommand pool cmd
-        addHistory cmd
-        next
-      )
+    ConnectionSource pool <- poolSource (cs {csComposites = ["book_"]}) (\connect disconnect -> defaultPoolConfig connect disconnect 1 10)
+    fix $ \next ->
+      readline "> "
+        >>= maybe
+          (printLn "")
+          ( \cmd -> do
+              when (cmd /= "quit") $ do
+                processCommand pool cmd
+                addHistory cmd
+                next
+          )

examples/OuterJoins.hs

@@ -0,0 +1,175 @@
+module OuterJoins (outerJoins) where
+
+import Control.Monad
+import Control.Monad.Base
+import Control.Monad.Catch
+import Data.Int
+import Data.Monoid.Utils
+import Data.Pool
+import Data.Text qualified as T
+import Database.PostgreSQL.PQTypes
+import System.Environment
+
+-- | Generic 'putStrLn'.
+printLn :: MonadBase IO m => String -> m ()
+printLn = liftBase . putStrLn
+
+-- | Get connection string from command line argument.
+getConnSettings :: IO ConnectionSettings
+getConnSettings = do
+  args <- getArgs
+  case args of
+    [conninfo] -> return defaultConnectionSettings {csConnInfo = T.pack conninfo}
+    _ -> do
+      prog <- getProgName
+      error $ "Usage:" <+> prog <+> "<connection info>"
+
+----------------------------------------
+
+tmpID :: Int64
+tmpID = 0
+
+data Attribute = Attribute
+  { attrID :: !Int64
+  , attrKey :: !String
+  , attrValues :: ![String]
+  }
+  deriving (Show)
+
+data Thing = Thing
+  { thingID :: !Int64
+  , thingName :: !String
+  , thingAttributes :: ![Attribute]
+  }
+  deriving (Show)
+
+type instance CompositeRow Attribute = (Int64, String, Array1 String)
+
+instance PQFormat Attribute where
+  pqFormat = "%attribute_"
+
+instance CompositeFromSQL Attribute where
+  toComposite (aid, key, Array1 values) =
+    Attribute
+      { attrID = aid
+      , attrKey = key
+      , attrValues = values
+      }
+
+withDB :: ConnectionSettings -> IO () -> IO ()
+withDB settings = bracket_ createStructure dropStructure
+  where
+    ConnectionSource cs = simpleSource settings
+
+    createStructure = runDBT cs defaultTransactionSettings $ do
+      printLn "Creating tables..."
+      runSQL_ $
+        mconcat
+          [ "CREATE TABLE things_ ("
+          , "  id BIGSERIAL NOT NULL"
+          , ", name TEXT NOT NULL"
+          , ", PRIMARY KEY (id)"
+          , ")"
+          ]
+      runSQL_ $
+        mconcat
+          [ "CREATE TABLE attributes_ ("
+          , "  id BIGSERIAL NOT NULL"
+          , ", key TEXT NOT NULL"
+          , ", thing_id BIGINT NOT NULL"
+          , ", PRIMARY KEY (id)"
+          , ", FOREIGN KEY (thing_id) REFERENCES things_ (id)"
+          , ")"
+          ]
+      runSQL_ $
+        mconcat
+          [ "CREATE TABLE values_ ("
+          , "  attribute_id BIGINT NOT NULL"
+          , ", value TEXT NOT NULL"
+          , ", FOREIGN KEY (attribute_id) REFERENCES attributes_ (id)"
+          , ")"
+          ]
+      runSQL_ $
+        mconcat
+          [ "CREATE TYPE attribute_ AS ("
+          , "  id BIGINT"
+          , ", key TEXT"
+          , ", value TEXT[]"
+          , ")"
+          ]
+    -- Drop previously created database structures.
+    dropStructure = runDBT cs defaultTransactionSettings $ do
+      printLn "Dropping tables..."
+      runSQL_ "DROP TYPE attribute_"
+      runSQL_ "DROP TABLE values_"
+      runSQL_ "DROP TABLE attributes_"
+      runSQL_ "DROP TABLE things_"
+
+insertThings :: [Thing] -> DBT IO ()
+insertThings = mapM_ $ \Thing {..} -> do
+  runQuery_ $
+    rawSQL
+      "INSERT INTO things_ (name) VALUES ($1) RETURNING id"
+      (Identity thingName)
+  tid :: Int64 <- fetchOne runIdentity
+  forM_ thingAttributes $ \Attribute {..} -> do
+    runQuery_ $
+      rawSQL
+        "INSERT INTO attributes_ (key, thing_id) VALUES ($1, $2) RETURNING id"
+        (attrKey, tid)
+    aid :: Int64 <- fetchOne runIdentity
+    forM_ attrValues $ \value ->
+      runQuery_ $
+        rawSQL
+          "INSERT INTO values_ (attribute_id, value) VALUES ($1, $2)"
+          (aid, value)
+
+selectThings :: DBT IO [Thing]
+selectThings = do
+  runSQL_ $ "SELECT t.id, t.name, ARRAY(" <> attributes <> ") FROM things_ t ORDER BY t.id"
+  fetchMany $ \(tid, name, CompositeArray1 attrs) ->
+    Thing
+      { thingID = tid
+      , thingName = name
+      , thingAttributes = attrs
+      }
+  where
+    attributes = "SELECT (a.id, a.key, ARRAY(" <> values <> "))::attribute_ FROM attributes_ a WHERE a.thing_id = t.id ORDER BY a.id"
+    values = "SELECT v.value FROM values_ v WHERE v.attribute_id = a.id ORDER BY v.value"
+
+outerJoins :: IO ()
+outerJoins = do
+  cs <- getConnSettings
+  withDB cs $ do
+    ConnectionSource pool <- poolSource (cs {csComposites = ["attribute_"]}) (\connect disconnect -> defaultPoolConfig connect disconnect 1 10)
+    runDBT pool defaultTransactionSettings $ do
+      insertThings
+        [ Thing
+            { thingID = tmpID
+            , thingName = "thing1"
+            , thingAttributes =
+                [ Attribute
+                    { attrID = tmpID
+                    , attrKey = "key1"
+                    , attrValues = ["foo"]
+                    }
+                , Attribute
+                    { attrID = tmpID
+                    , attrKey = "key2"
+                    , attrValues = []
+                    }
+                ]
+            }
+        , Thing
+            { thingID = tmpID
+            , thingName = "thing2"
+            , thingAttributes =
+                [ Attribute
+                    { attrID = tmpID
+                    , attrKey = "key2"
+                    , attrValues = ["bar", "baz"]
+                    }
+                ]
+            }
+        ]
+      selectThings >>= mapM_ (printLn . show)