module Snap.Snaplet.Persistent
( initPersist
, initPersistGeneric
, PersistState(..)
, HasPersistPool(..)
, mkPgPool
, mkSnapletPgPool
, runPersist
, withPool
, mkKey
, mkKeyBS
, mkKeyT
, showKey
, showKeyBS
, mkInt
, mkWord64
, followForeignKey
, fromPersistValue'
) where
import Control.Monad.Logger
import Control.Monad.State
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.Configurator
import Data.Configurator.Types
import Data.Maybe
import Data.Pool
import Data.Readable
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word
import Database.Persist
import Database.Persist.Postgresql hiding (get)
import qualified Database.Persist.Postgresql as DB
import Paths_snaplet_persistent
import Snap.Snaplet
newtype PersistState = PersistState { persistPool :: ConnectionPool }
class MonadIO m => HasPersistPool m where
getPersistPool :: m ConnectionPool
instance HasPersistPool m => HasPersistPool (NoLoggingT m) where
getPersistPool = runNoLoggingT getPersistPool
instance HasPersistPool (Handler b PersistState) where
getPersistPool = gets persistPool
instance MonadIO m => HasPersistPool (ReaderT ConnectionPool m) where
getPersistPool = ask
initPersist :: SqlPersistT (NoLoggingT IO) a -> SnapletInit b PersistState
initPersist = initPersistGeneric mkSnapletPgPool
initPersistGeneric
:: Initializer b PersistState (Pool SqlBackend)
-> SqlPersistT (NoLoggingT IO) a
-> SnapletInit b PersistState
initPersistGeneric mkPool migration = makeSnaplet "persist" description datadir $ do
p <- mkPool
_ <- liftIO $ runNoLoggingT $ runSqlPool migration p
return $ PersistState p
where
description = "Snaplet for persistent DB library"
datadir = Just $ liftM (++"/resources/db") getDataDir
mkPgPool :: MonadIO m => Config -> m ConnectionPool
mkPgPool conf = do
pgConStr <- liftIO $ require conf "postgre-con-str"
cons <- liftIO $ require conf "postgre-pool-size"
liftIO . runNoLoggingT $ createPostgresqlPool pgConStr cons
mkSnapletPgPool :: (MonadIO (m b v), MonadSnaplet m) => m b v ConnectionPool
mkSnapletPgPool = do
conf <- getSnapletUserConfig
mkPgPool conf
runPersist :: (HasPersistPool m)
=> SqlPersistT (ResourceT (NoLoggingT IO)) b
-> m b
runPersist action = do
pool <- getPersistPool
withPool pool action
withPool :: MonadIO m
=> ConnectionPool
-> SqlPersistT (ResourceT (NoLoggingT IO)) a -> m a
withPool cp f = liftIO . runNoLoggingT . runResourceT $ runSqlPool f cp
mkKey :: ToBackendKey SqlBackend entity => Int -> Key entity
mkKey = fromBackendKey . SqlBackendKey . fromIntegral
mkKeyBS :: ToBackendKey SqlBackend entity => ByteString -> Key entity
mkKeyBS = mkKey . fromMaybe (error "Can't ByteString value") . fromBS
mkKeyT :: ToBackendKey SqlBackend entity => Text -> Key entity
mkKeyT = mkKey . fromMaybe (error "Can't Text value") . fromText
showKey :: ToBackendKey SqlBackend e => Key e -> Text
showKey = T.pack . show . mkInt
showKeyBS :: ToBackendKey SqlBackend e => Key e -> ByteString
showKeyBS = T.encodeUtf8 . showKey
mkInt :: ToBackendKey SqlBackend a => Key a -> Int
mkInt = fromIntegral . unSqlBackendKey . toBackendKey
mkWord64 :: ToBackendKey SqlBackend a => Key a -> Word64
mkWord64 = fromIntegral . unSqlBackendKey . toBackendKey
fromPersistValue' :: PersistField c => PersistValue -> c
fromPersistValue' = either (const $ error "Persist conversion failed") id
. fromPersistValue
followForeignKey :: (PersistEntity a, HasPersistPool m,
PersistEntityBackend a ~ SqlBackend)
=> (t -> Key a) -> Entity t -> m (Maybe (Entity a))
followForeignKey toKey (Entity _ val) = do
let key' = toKey val
mval <- runPersist $ DB.get key'
return $ fmap (Entity key') mval