CODEWITHSUNDEEP
haskellmonadsmonad-transformershappstack
Lanbo
Lanbo

Reputation: 15702

Extending the ServerPartT Monad with a Reader

I am writing a Happstack server and I have a MongoDB database to connect to. For that, I made a function to create a connection pool

type MongoPool = Pool IOError Pipe

withMongo :: (MongoPool -> IO a) -> IO ()
withMongo f = do
    pool <- dbPool
    f pool
    killAll pool

And then a function to run an Action with a created pool:

runDB :: (MonadIO m) => MongoPool -> Action IO a -> m (Either Failure a)
runDB pool f = liftIO $ do
    pipe <- runIOE $ aResource pool
    access pipe master dbName f

It's obvious this requires to carry the pool in all the routes as a parameter. I would like to wrap it into a ReaderT, so that runDB can have a type like Action IO a -> ServerPart (Either Failure a) or even better, Action IO a -> ServerPart a in which a failure will result in an HTTP Error 500 automatically.

I have a trouble wrapping my head around how that can be achieved and I'd love for some hints from people who've more experience with Haskell monads and happstack.

Thanks.

Upvotes: 3

Views: 174

Answers (1)

Lanbo
Lanbo

Reputation: 15702

Through this question I found another with a very good hint, and I have built this. It seems to work fine and I thought I'd share it:

type MongoPool = Pool IOError Pipe

type DBServerPart a = ReaderT MongoPool (ServerPartT IO) a

hostName = "127.0.0.1"

dbName = "test"

defaultPoolSize = 10

runDB :: Action IO a -> DBServerPart (Either Failure a)
runDB f = do
    pool <- ask
    liftIO $ do
        pipe <- runIOE $ aResource pool
        access pipe master dbName f

withMongo :: DBServerPart a -> ServerPart a
withMongo f = do
    pool <- liftIO $ dbPool
    a <- runReaderT f pool
    liftIO $ killAll pool
    return a

dbPool = newPool fac defaultPoolSize
    where fac = Factory {
            newResource = connect $ host hostName,
            killResource = close,
            isExpired = isClosed
        }

Upvotes: 3

Related Questions