Fix GraphQL example + pools in mu-persistent (#261)

.github/workflows/deploy.yml

@@ -7,16 +7,16 @@ jobs:
   build:
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v1
-    - uses: mstksg/setup-stack@v1
-    - uses: actions/cache@v1
+    - uses: actions/checkout@v2.3.4
+    - uses: mstksg/setup-stack@v2
+    - uses: actions/cache@v2.1.3
       name: Cache ~/.stack
       with:
         path: ~/.stack
         key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}
         restore-keys: |
           ${{ runner.os }}-stack-
-    - uses: actions/cache@v1
+    - uses: actions/cache@v2.1.3
       name: Cache .stack-work
       with:
         path: .stack-work
@@ -46,7 +46,7 @@ jobs:
         bash ./generate-haddock-docs.sh
         BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll build -b /mu-haskell/wip -s docs -d gen-docs/wip
     - name: Deploy microsite
-      uses: peaceiris/actions-gh-pages@v2
+      uses: peaceiris/actions-gh-pages@v3.7.3
       env:
         ACTIONS_DEPLOY_KEY: ${{ secrets.ACTIONS_DEPLOY_KEY }}
         PUBLISH_BRANCH: gh-pages

.github/workflows/haskell.yml

@@ -4,9 +4,9 @@ jobs:
   build:
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v1
-    - uses: cachix/install-nix-action@v10
-    - uses: cachix/cachix-action@v6
+    - uses: actions/checkout@v2.3.4
+    - uses: cachix/install-nix-action@v12
+    - uses: cachix/cachix-action@v8
       with:
         name: 47deg
         signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}'

adapter/persistent/mu-persistent.cabal

@@ -1,5 +1,5 @@
 name:               mu-persistent
-version:            0.3.0.0
+version:            0.3.1.0
 synopsis:           Utilities for interoperation between Mu and Persistent
 description:
   Please see the <https://github.com/higherkindness/mu-haskell/persistent#readme readme file>.
@@ -32,6 +32,7 @@ library
     , mu-schema     ==0.3.*
     , persistent    >=2.10 && <3
     , resourcet     >=1.2  && <2
+    , resource-pool >=0.2  && <0.3
     , transformers  >=0.5  && <0.6
 
   ghc-options:      -Wall

adapter/persistent/src/Mu/Adapter/Persistent.hs

@@ -21,7 +21,7 @@ module Mu.Adapter.Persistent (
   WithEntityNestedId(..)
 , WithEntityPlainId(..)
   -- * Generic utilities
-, runDb
+, runDb, Pool, runDbPool
 ) where
 
 import           Control.Monad.IO.Class
@@ -29,6 +29,7 @@ import           Control.Monad.Logger
 import           Control.Monad.Trans.Reader
 import           Control.Monad.Trans.Resource.Internal
 import           Data.Int
+import           Data.Pool                             (Pool)
 import           Database.Persist.Sql
 import           GHC.Generics
 import           GHC.TypeLits
@@ -95,3 +96,12 @@ runDb :: MonadIO m
       -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
       -> m a
 runDb = (liftIO .) . flip runSqlPersistM
+
+-- | Simple utility to execute a database operation
+--   in any monad which supports 'IO' operations.
+--   Note that all logging messages are discarded.
+runDbPool :: MonadIO m
+          => Pool SqlBackend
+          -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
+          -> m a
+runDbPool = (liftIO .) . flip runSqlPersistMPool

examples/library/src/Server.hs

@@ -11,10 +11,11 @@ module Main where
 import           Control.Monad.IO.Class            (liftIO)
 import           Control.Monad.Logger              (LoggingT, runStderrLoggingT)
 import           Data.Conduit                      (ConduitT, Void, runConduit, (.|))
+import           Data.Conduit.Combinators          (yieldMany)
 import           Data.Maybe                        (fromJust)
 import qualified Data.Text                         as T
 import           Database.Persist.Sqlite
-import           Mu.Adapter.Persistent             (runDb)
+import           Mu.Adapter.Persistent             (Pool, runDbPool)
 import           Mu.GraphQL.Server                 (graphQLApp, liftServerConduit)
 import           Mu.Instrumentation.Prometheus     (initPrometheus, prometheus)
 import           Mu.Schema                         (Mapping ((:->)), Proxy (Proxy))
@@ -35,8 +36,8 @@ main = do
   p <- initPrometheus "library"
   -- Run the whole thing
   runStderrLoggingT $
-    withSqliteConn @(LoggingT IO) ":memory:" $ \conn -> do
-      runDb conn $ runMigration migrateAll
+    withSqlitePool @(LoggingT IO) ":memory:" 1000 $ \conn -> do
+      runDbPool conn $ runMigration migrateAll
       -- Insert demo data
       insertSeedData conn
       liftIO $ putStrLn "starting GraphQL server on port 8000"
@@ -49,7 +50,7 @@ main = do
 {- | Inserts demo data to make this example valueable for testing with different clients
      Returns Nothing in case of any failure, including attempts to insert non-unique values
 -}
-insertSeedData :: SqlBackend -> LoggingT IO (Maybe ())
+insertSeedData :: Pool SqlBackend -> LoggingT IO (Maybe ())
 insertSeedData conn = sequence_ <$> traverse (uncurry $ insertAuthorAndBooks conn) seedData
   where seedData =
           [ (Author "Robert Louis Stevenson",
@@ -67,9 +68,9 @@ insertSeedData conn = sequence_ <$> traverse (uncurry $ insertAuthorAndBooks con
 {- | Inserts Author and Books
      Returns Nothing in case of any failure, including attempts to insert non-unique values
 -}
-insertAuthorAndBooks :: SqlBackend -> Author -> [Key Author -> Book] -> LoggingT IO (Maybe ())
+insertAuthorAndBooks :: Pool SqlBackend -> Author -> [Key Author -> Book] -> LoggingT IO (Maybe ())
 insertAuthorAndBooks conn author books =
-  runDb conn . fmap sequence_ $ do
+  runDbPool conn . fmap sequence_ $ do
     authorResult <- insertUnique author
     case authorResult of
       Just authorId -> traverse (\kBook -> insertUnique (kBook authorId)) books
@@ -80,7 +81,7 @@ type ObjectMapping = '[
   , "Author" ':-> Entity Author
   ]
 
-libraryServer :: SqlBackend -> ServerT ObjectMapping i Library ServerErrorIO _
+libraryServer :: Pool SqlBackend -> ServerT ObjectMapping i Library ServerErrorIO _
 libraryServer conn = resolver
   ( object @"Book"
     ( field @"id"       bookId
@@ -110,7 +111,9 @@ libraryServer conn = resolver
     bookTitle :: Entity Book -> ServerErrorIO T.Text
     bookTitle (Entity _ Book { bookTitle }) = pure bookTitle
     bookAuthor :: Entity Book -> ServerErrorIO (Entity Author)
-    bookAuthor (Entity _ Book { bookAuthor }) = runDb conn $ Entity bookAuthor . fromJust <$> get bookAuthor
+    bookAuthor (Entity _ Book { bookAuthor }) = do
+      author <- runDbPool conn $ get bookAuthor
+      pure $ Entity bookAuthor (fromJust author)
     bookImage :: Entity Book -> ServerErrorIO T.Text
     bookImage (Entity _ Book { bookImageUrl }) = pure bookImageUrl
 
@@ -119,22 +122,37 @@ libraryServer conn = resolver
     authorName :: Entity Author -> ServerErrorIO T.Text
     authorName (Entity _ Author { authorName }) = pure authorName
     authorBooks :: Entity Author -> ServerErrorIO [Entity Book]
-    authorBooks (Entity author _) = runDb conn $ selectList [BookAuthor ==. author] [Asc BookTitle]
+    authorBooks (Entity author _)
+      = runDbPool conn $
+          selectList [BookAuthor ==. author] [Asc BookTitle]
 
     allAuthors :: T.Text -> ServerErrorIO [Entity Author]
     allAuthors nameFilter
-      = runDb conn $ selectList [Filter AuthorName (FilterValue nameFilter) (BackendSpecificFilter "LIKE")] [Asc AuthorName]
+      = runDbPool conn $
+          selectList [Filter AuthorName (FilterValue nameFilter)
+                             (BackendSpecificFilter "LIKE")]
+                     [Asc AuthorName]
 
     allBooks :: T.Text -> ServerErrorIO [Entity Book]
     allBooks titleFilter
-      = runDb conn $ selectList [Filter BookTitle (FilterValue titleFilter) (BackendSpecificFilter "LIKE")] [Asc BookTitle]
+      = runDbPool conn $
+          selectList [Filter BookTitle (FilterValue titleFilter)
+                             (BackendSpecificFilter "LIKE")]
+                     [Asc BookTitle]
 
     allBooksConduit :: ConduitT (Entity Book) Void ServerErrorIO () -> ServerErrorIO ()
-    allBooksConduit sink = runDb conn $ runConduit $ selectSource [] [Asc BookTitle] .| liftServerConduit sink
+    allBooksConduit sink = do
+      -- do not convert to a single selectConduit!
+      -- there seems to be a problem running nested runDb's
+      -- so we break it into two steps, assuming that the
+      -- list of books would fit in memory
+      -- see https://github.com/higherkindness/mu-haskell/issues/259
+      lst <- liftIO $ runDbPool conn $ selectList [] [Asc BookTitle]
+      runConduit $ yieldMany lst .| liftServerConduit sink
 
     newAuthor :: NewAuthor -> ServerErrorIO (Entity Author)
     newAuthor (NewAuthor name) = do
-      maybeEntity <- runDb conn $ do
+      maybeEntity <- runDbPool conn $ do
         let new = Author name
         result <- insertUnique new
         pure $ Entity <$> result <*> pure new
@@ -143,7 +161,7 @@ libraryServer conn = resolver
 
     newBook :: NewBook -> ServerErrorIO (Entity Book)
     newBook (NewBook title authorId img) = do
-      maybeEntity <- runDb conn $ do
+      maybeEntity <- runDbPool conn $ do
         let new = Book title img (toAuthorId $ fromInteger authorId)
         result <- insertUnique new
         pure $ Entity <$> result <*> pure new