Core.hs 5.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170
  1. {-# LANGUAGE ConstraintKinds #-}
  2. {-# LANGUAGE TypeFamilies #-}
  3. {-# LANGUAGE CPP #-}
  4. {-# LANGUAGE FlexibleContexts #-}
  5. {-# LANGUAGE RankNTypes #-}
  6. {-# OPTIONS_GHC -fno-warn-orphans #-}
  7. -- | Defines the core functionality of this package. This package is
  8. -- distinguished from Yesod.Persist in that the latter additionally exports the
  9. -- persistent modules themselves.
  10. module Yesod.Persist.Core
  11. ( YesodPersist (..)
  12. , defaultRunDB
  13. , YesodPersistRunner (..)
  14. , defaultGetDBRunner
  15. , DBRunner (..)
  16. , runDBSource
  17. , respondSourceDB
  18. , YesodDB
  19. , get404
  20. , getBy404
  21. ) where
  22. import Database.Persist
  23. import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
  24. import Yesod.Core
  25. import Data.Conduit
  26. import Blaze.ByteString.Builder (Builder)
  27. import Data.Pool
  28. import Control.Monad.Trans.Resource
  29. import Control.Exception (throwIO)
  30. import Yesod.Core.Types (HandlerContents (HCError))
  31. import qualified Database.Persist.Sql as SQL
  32. unSqlPersistT :: a -> a
  33. unSqlPersistT = id
  34. type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO)
  35. class Monad (YesodDB site) => YesodPersist site where
  36. type YesodPersistBackend site
  37. runDB :: YesodDB site a -> HandlerT site IO a
  38. -- | Helper for creating 'runDB'.
  39. --
  40. -- Since 1.2.0
  41. defaultRunDB :: PersistConfig c
  42. => (site -> c)
  43. -> (site -> PersistConfigPool c)
  44. -> PersistConfigBackend c (HandlerT site IO) a
  45. -> HandlerT site IO a
  46. defaultRunDB getConfig getPool f = do
  47. master <- getYesod
  48. Database.Persist.runPool
  49. (getConfig master)
  50. f
  51. (getPool master)
  52. -- |
  53. --
  54. -- Since 1.2.0
  55. class YesodPersist site => YesodPersistRunner site where
  56. -- | This function differs from 'runDB' in that it returns a database
  57. -- runner function, as opposed to simply running a single action. This will
  58. -- usually mean that a connection is taken from a pool and then reused for
  59. -- each invocation. This can be useful for creating streaming responses;
  60. -- see 'runDBSource'.
  61. --
  62. -- It additionally returns a cleanup function to free the connection. If
  63. -- your code finishes successfully, you /must/ call this cleanup to
  64. -- indicate changes should be committed. Otherwise, for SQL backends at
  65. -- least, a rollback will be used instead.
  66. --
  67. -- Since 1.2.0
  68. getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
  69. newtype DBRunner site = DBRunner
  70. { runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
  71. }
  72. -- | Helper for implementing 'getDBRunner'.
  73. --
  74. -- Since 1.2.0
  75. #if MIN_VERSION_persistent(2,5,0)
  76. defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
  77. => (site -> Pool backend)
  78. -> HandlerT site IO (DBRunner site, HandlerT site IO ())
  79. #else
  80. defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
  81. => (site -> Pool SQL.SqlBackend)
  82. -> HandlerT site IO (DBRunner site, HandlerT site IO ())
  83. #endif
  84. defaultGetDBRunner getPool = do
  85. pool <- fmap getPool getYesod
  86. let withPrep conn f = f (persistBackend conn) (SQL.connPrepare $ persistBackend conn)
  87. (relKey, (conn, local)) <- allocate
  88. (do
  89. (conn, local) <- takeResource pool
  90. withPrep conn SQL.connBegin
  91. return (conn, local)
  92. )
  93. (\(conn, local) -> do
  94. withPrep conn SQL.connRollback
  95. destroyResource pool local conn)
  96. let cleanup = liftIO $ do
  97. withPrep conn SQL.connCommit
  98. putResource local conn
  99. _ <- unprotect relKey
  100. return ()
  101. return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)
  102. -- | Like 'runDB', but transforms a @Source@. See 'respondSourceDB' for an
  103. -- example, practical use case.
  104. --
  105. -- Since 1.2.0
  106. runDBSource :: YesodPersistRunner site
  107. => Source (YesodDB site) a
  108. -> Source (HandlerT site IO) a
  109. runDBSource src = do
  110. (dbrunner, cleanup) <- lift getDBRunner
  111. transPipe (runDBRunner dbrunner) src
  112. lift cleanup
  113. -- | Extends 'respondSource' to create a streaming database response body.
  114. respondSourceDB :: YesodPersistRunner site
  115. => ContentType
  116. -> Source (YesodDB site) (Flush Builder)
  117. -> HandlerT site IO TypedContent
  118. respondSourceDB ctype = respondSource ctype . runDBSource
  119. -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
  120. #if MIN_VERSION_persistent(2,5,0)
  121. get404 :: (MonadIO m, PersistStore backend, PersistRecordBackend val backend)
  122. => Key val
  123. -> ReaderT backend m val
  124. #else
  125. get404 :: (MonadIO m, PersistStore (PersistEntityBackend val), PersistEntity val)
  126. => Key val
  127. -> ReaderT (PersistEntityBackend val) m val
  128. #endif
  129. get404 key = do
  130. mres <- get key
  131. case mres of
  132. Nothing -> notFound'
  133. Just res -> return res
  134. -- | Get the given entity by unique key, or return a 404 not found if it doesn't
  135. -- exist.
  136. #if MIN_VERSION_persistent(2,5,0)
  137. getBy404 :: (PersistUnique backend, PersistRecordBackend val backend, MonadIO m)
  138. => Unique val
  139. -> ReaderT backend m (Entity val)
  140. #else
  141. getBy404 :: (PersistUnique (PersistEntityBackend val), PersistEntity val, MonadIO m)
  142. => Unique val
  143. -> ReaderT (PersistEntityBackend val) m (Entity val)
  144. #endif
  145. getBy404 key = do
  146. mres <- getBy key
  147. case mres of
  148. Nothing -> notFound'
  149. Just res -> return res
  150. -- | Should be equivalent to @lift . notFound@, but there's an apparent bug in
  151. -- GHC 7.4.2 that leads to segfaults. This is a workaround.
  152. notFound' :: MonadIO m => m a
  153. notFound' = liftIO $ throwIO $ HCError NotFound