mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Fix GraphQL example + pools in mu-persistent (#261)
This commit is contained in:
parent
16ac8ec688
commit
37d6762883
10
.github/workflows/deploy.yml
vendored
10
.github/workflows/deploy.yml
vendored
@ -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
|
||||
|
6
.github/workflows/haskell.yml
vendored
6
.github/workflows/haskell.yml
vendored
@ -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 }}'
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user