Upgrade stack lts 3.22 (#1)

* lts-3.22
* bump up version to 0.1.0

.gitignore

@@ -3,3 +3,5 @@ dist
 *.log
 .cabal-sandbox
 cabal.sandbox.config
+.stack-work
+TAGS

snaplet-mongodb-minimalistic.cabal

@@ -1,18 +1,15 @@
 Name:               snaplet-mongodb-minimalistic
-Version:            0.0.6.12
+Version:            0.1.0
 Synopsis:           Minimalistic MongoDB Snaplet.
 Description:        Minimalistic MongoDB Snaplet.
 License:            BSD3
 License-file:       LICENSE
 Author:             Petr Pilař
 Maintainer:         [email protected]
 Build-type:         Simple
-Cabal-version:      >= 1.6
 Homepage:           https://github.com/Palmik/snaplet-mongodb-minimalistic
 Category:           Web
-
 Build-type:          Simple
-
 Cabal-version:       >= 1.10
 
 Source-repository head
@@ -21,25 +18,26 @@ Source-repository head
 
 Library
   hs-source-dirs: src
-  default-language:    Haskell2010
+  default-language: Haskell2010
 
   Exposed-modules:
-    Snap.Snaplet.MongoDB,
-    Snap.Snaplet.MongoDB.Core,
-    Snap.Snaplet.MongoDB.Functions,
-    Snap.Snaplet.MongoDB.Functions.S,
-    Snap.Snaplet.MongoDB.Functions.M
+                  Snap.Snaplet.MongoDB,
+                  Snap.Snaplet.MongoDB.Core,
+                  Snap.Snaplet.MongoDB.Functions,
+                  Snap.Snaplet.MongoDB.Functions.S,
+                  Snap.Snaplet.MongoDB.Functions.M
 
   Other-modules:
 
   Build-depends:
-    base                        >= 4 && < 5,
-    lens                        >= 3.7 && < 3.11,
-    mtl                         >= 2.0 && < 2.2,
-    transformers                >= 0.2 && < 0.4,
-    snap                        >= 0.11 && < 0.14,
-    text                        >= 0.11 && < 1.2,
-    mongoDB                     >= 1.4 && < 1.5
+                 base >= 4 && < 5
+               , lens
+               , mtl
+               , transformers
+               , snap
+               , text
+               , mongoDB
+               , resource-pool
+               , monad-control
 
   GHC-Options: -Wall
-

src/Snap/Snaplet/MongoDB/Core.hs

@@ -15,7 +15,8 @@ import           Data.Text (Text)
 import           Snap.Snaplet
 import           Control.Monad.IO.Class
 import           Database.MongoDB (Database, Host, Pipe, AccessMode (UnconfirmedWrites), close, isClosed, connect)
-import           System.IO.Pool (Pool, Factory (Factory), newPool)
+import           Data.Pool(Pool, createPool)
+--import           System.IO.Pool (Pool, Factory (Factory), newPool)
 
 ------------------------------------------------------------------------------
 
@@ -26,23 +27,23 @@ description = "Minimalistic MongoDB Snaplet."
 
 ------------------------------------------------------------------------------
 -- | MongoDB Pool type
-type MongoDBPool = Pool IOError Pipe
+type MongoDBPool = Pool Pipe
 
 ------------------------------------------------------------------------------
 -- | Snaplet's data type.
 --
 -- Usage:
--- 
+--
 -- > data App = App
 -- >     { _heist :: Snaplet (Heist App)
 -- >     , _database :: Snaplet MongoDB
 -- >     }
 data MongoDB = MongoDB
-    { mongoPool :: Pool IOError Pipe
+    { mongoPool :: MongoDBPool
     , mongoDatabase :: Database
     , mongoAccessMode :: AccessMode
     }
-    
+
 ------------------------------------------------------------------------------
 -- | Snaplet's type-class.
 --
@@ -68,7 +69,7 @@ mongoDBInit :: Int                      -- ^ Maximum pool size.
             -> Database                 -- ^ Database name.
             -> SnapletInit app MongoDB
 mongoDBInit n h d = makeSnaplet "snaplet-mongodb" description Nothing $ do
-    pool <- liftIO $ newPool (Factory (connect h) close isClosed) n
+    pool <- liftIO $ createPool (connect h) close 1 10 n
     return $ MongoDB pool d UnconfirmedWrites
 
 ------------------------------------------------------------------------------
@@ -87,6 +88,5 @@ mongoDBInit' :: Int                      -- ^ Maximum pool size.
              -> AccessMode               -- ^ Default access mode to be used with this snaplet.
              -> SnapletInit app MongoDB
 mongoDBInit' n h d m = makeSnaplet "snaplet-mongodb" description Nothing $ do
-    pool <- liftIO $ newPool (Factory (connect h) close isClosed) n
+    pool <- liftIO $ createPool (connect h) close 1 10 n
     return $ MongoDB pool d m
-

src/Snap/Snaplet/MongoDB/Functions/M.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE FlexibleContexts     #-}
 
 ------------------------------------------------------------------------------
 -- | In this module you can find variations of @withDB@ functions.
@@ -12,27 +13,29 @@ module Snap.Snaplet.MongoDB.Functions.M
 , maybeWithDB'
 , unsafeWithDB
 , unsafeWithDB'
-) where 
+) where
 
-import           Control.Monad (liftM)
-import           Control.Monad.Error (runErrorT)
+import Control.Monad.IO.Class
+import Control.Monad.State.Class
+import Control.Monad
 import           Control.Lens (cloneLens, use)
 
-import           Snap (MonadIO, MonadState, liftIO, SnapletLens, snapletValue)
+import           Snap (SnapletLens, snapletValue)
 import           Snap.Snaplet.MongoDB.Core
 
 import           Database.MongoDB (Action, AccessMode, Failure (ConnectionFailure), access)
-import           System.IO.Pool (aResource)
+import Data.Pool
+import Control.Monad.Trans.Control
 
 ------------------------------------------------------------------------------
 -- | Database access function.
 --
 -- Example:
 --
 -- > unsafeWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ]
-unsafeWithDB :: (MonadIO m, MonadState app m)
+unsafeWithDB :: (MonadIO m, MonadState app m, MonadBaseControl IO m)
              => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
-             -> Action IO a             -- ^ 'Action' you want to perform.
+             -> Action m a             -- ^ 'Action' you want to perform.
              -> m a                     -- ^ The action's result; in case of failure 'error' is called.
 unsafeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (unsafeWithDB' snaplet) action
 
@@ -42,10 +45,10 @@ unsafeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (unsafeWithDB'
 -- Example:
 --
 -- > unsafeWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
-unsafeWithDB' :: (MonadIO m, MonadState app m)
+unsafeWithDB' :: (MonadIO m, MonadState app m, MonadBaseControl IO m)
               => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
               -> AccessMode              -- ^ Access mode you want to use when performing the action.
-              -> Action IO a             -- ^ 'Action' you want to perform.
+              -> Action m a             -- ^ 'Action' you want to perform.
               -> m a                     -- ^ The action's result; in case of failure 'error' is called.
 unsafeWithDB' snaplet mode action = do
     res <- eitherWithDB' snaplet mode action
@@ -57,9 +60,9 @@ unsafeWithDB' snaplet mode action = do
 -- Example:
 --
 -- > maybeWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ]
-maybeWithDB :: (MonadIO m, MonadState app m)
+maybeWithDB :: (MonadIO m, MonadState app m, MonadBaseControl IO m)
             => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
-            -> Action IO a             -- ^ 'Action' you want to perform.
+            -> Action m a             -- ^ 'Action' you want to perform.
             -> m (Maybe a)             -- ^ 'Nothing' in case of failure or 'Just' the result of the action.
 maybeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (maybeWithDB' snaplet) action
 
@@ -69,10 +72,10 @@ maybeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (maybeWithDB' s
 -- Example:
 --
 -- > maybeWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
-maybeWithDB' :: (MonadIO m, MonadState app m)
+maybeWithDB' :: (MonadIO m, MonadState app m, MonadBaseControl IO m)
              => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
              -> AccessMode              -- ^ Access mode you want to use when performing the action.
-             -> Action IO a             -- ^ 'Action' you want to perform.
+             -> Action m a             -- ^ 'Action' you want to perform.
              -> m (Maybe a)             -- ^ 'Nothing' in case of failure or 'Just' the result of the action.
 maybeWithDB' snaplet mode action = do
     res <- eitherWithDB' snaplet mode action
@@ -84,9 +87,9 @@ maybeWithDB' snaplet mode action = do
 -- Example:
 --
 -- > eitherWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ]
-eitherWithDB :: (MonadIO m, MonadState app m)
+eitherWithDB :: (MonadIO m, MonadState app m, MonadBaseControl IO m)
              => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
-             -> Action IO a             -- ^ 'Action' you want to perform.
+             -> Action m a             -- ^ 'Action' you want to perform.
              -> m (Either Failure a)    -- ^ 'Either' 'Failure' or the action's result.
 eitherWithDB snaplet action = getMongoAccessMode snaplet >>= flip (eitherWithDB' snaplet) action
 
@@ -96,17 +99,17 @@ eitherWithDB snaplet action = getMongoAccessMode snaplet >>= flip (eitherWithDB'
 -- Example:
 --
 -- > eitherWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
-eitherWithDB' :: (MonadIO m, MonadState app m)
+eitherWithDB' :: (MonadIO m, MonadState app m, MonadBaseControl IO m)
               => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
               -> AccessMode              -- ^ Access mode you want to use when performing the action.
-              -> Action IO a             -- ^ 'Action' you want to perform.
+              -> Action m a             -- ^ 'Action' you want to perform.
               -> m (Either Failure a)    -- ^ 'Either' 'Failure' or the action's result.
 eitherWithDB' snaplet mode action = do
     (MongoDB pool database _) <- use (cloneLens snaplet . snapletValue)
-    ep <- liftIO $ runErrorT $ aResource pool
-    case ep of
-         Left  err -> return $ Left $ ConnectionFailure err
-         Right pip -> liftIO $ access pip mode database action
+    r <- tryWithResource pool (\pip -> access pip mode database action)
+    case r of
+      Just a -> return $ Right a
+      Nothing -> return $ Left $ ConnectionFailure $ userError "can not find pool resource"
 
 getMongoAccessMode :: (MonadIO m, MonadState app m) => SnapletLens app MongoDB -> m AccessMode
 getMongoAccessMode snaplet = mongoAccessMode `liftM` use (cloneLens snaplet . snapletValue)

src/Snap/Snaplet/MongoDB/Functions/S.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE FlexibleContexts     #-}
 
 ------------------------------------------------------------------------------
 -- | In this module you can find variations of @withDB@ functions.
@@ -14,21 +15,25 @@ module Snap.Snaplet.MongoDB.Functions.S
 , unsafeWithDB'
 ) where
 
+import Control.Monad.IO.Class
+import Control.Monad.State.Class
+import Control.Monad
 import           Control.Monad.Error (runErrorT)
 import           Snap
 import           Snap.Snaplet.MongoDB.Core
 
 import           Database.MongoDB (Action, AccessMode, Failure (ConnectionFailure), access)
-import           System.IO.Pool (aResource)
+import Data.Pool
+import Control.Monad.Trans.Control
 
 ------------------------------------------------------------------------------
 -- | Database access function.
 --
 -- Usage:
 --
 -- > unsafeWithDB $ insert "test-collection" [ "some_field" = "something" ]
-unsafeWithDB :: (MonadIO m, MonadState app m, HasMongoDB app)
-             => Action IO a         -- ^ 'Action' you want to perform.
+unsafeWithDB :: (MonadIO m, MonadState app m, HasMongoDB app, MonadBaseControl IO m)
+             => Action m a         -- ^ 'Action' you want to perform.
              -> m a                 -- ^ The action's result; in case of failure 'error' is called.
 unsafeWithDB action = getMongoAccessMode >>= flip unsafeWithDB' action
 
@@ -38,9 +43,9 @@ unsafeWithDB action = getMongoAccessMode >>= flip unsafeWithDB' action
 -- Usage:
 --
 -- > unsafeWithDB' UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
-unsafeWithDB' :: (MonadIO m, MonadState app m, HasMongoDB app)
+unsafeWithDB' :: (MonadIO m, MonadState app m, HasMongoDB app, MonadBaseControl IO m)
               => AccessMode             -- ^ Access mode you want to use when performing the action.
-              -> Action IO a            -- ^ 'Action' you want to perform.
+              -> Action m a            -- ^ 'Action' you want to perform.
               -> m a                    -- ^ The action's result; in case of failure 'error' is called.
 unsafeWithDB' mode action = do
     res <- eitherWithDB' mode action
@@ -52,8 +57,8 @@ unsafeWithDB' mode action = do
 -- Usage:
 --
 -- > maybeWithDB $ insert "test-collection" [ "some_field" = "something" ]
-maybeWithDB :: (MonadIO m, MonadState app m, HasMongoDB app)
-            => Action IO a          -- ^ 'Action' you want to perform.
+maybeWithDB :: (MonadIO m, MonadState app m, HasMongoDB app, MonadBaseControl IO m)
+            => Action m a          -- ^ 'Action' you want to perform.
             -> m (Maybe a)          -- ^ 'Nothing' in case of failure or 'Just' the result of the action.
 maybeWithDB action = getMongoAccessMode >>= flip maybeWithDB' action
 
@@ -63,9 +68,9 @@ maybeWithDB action = getMongoAccessMode >>= flip maybeWithDB' action
 -- Usage:
 --
 -- > maybeWithDB' UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
-maybeWithDB' :: (MonadIO m, MonadState app m, HasMongoDB app)
+maybeWithDB' :: (MonadIO m, MonadState app m, HasMongoDB app, MonadBaseControl IO m)
              => AccessMode          -- ^ Access mode you want to use when performing the action.
-             -> Action IO a         -- ^ 'Action' you want to perform.
+             -> Action m a         -- ^ 'Action' you want to perform.
              -> m (Maybe a)         -- ^ 'Nothing' in case of failure or 'Just' the result of the action.
 maybeWithDB' mode action = do
     res <- eitherWithDB' mode action
@@ -77,8 +82,8 @@ maybeWithDB' mode action = do
 -- Usage:
 --
 -- > eitherWithDB $ insert "test-collection" [ "some_field" = "something" ]
-eitherWithDB :: (MonadIO m, MonadState app m, HasMongoDB app)
-             => Action IO a             -- ^ 'Action' you want to perform.
+eitherWithDB :: (MonadIO m, MonadState app m, HasMongoDB app, MonadBaseControl IO m)
+             => Action m a             -- ^ 'Action' you want to perform.
              -> m (Either Failure a)    -- ^ 'Either' 'Failure' or the action's result.
 eitherWithDB action = getMongoAccessMode >>= flip eitherWithDB' action
 
@@ -88,16 +93,16 @@ eitherWithDB action = getMongoAccessMode >>= flip eitherWithDB' action
 -- Usage:
 --
 -- > eitherWithDB' UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
-eitherWithDB' :: (MonadIO m, MonadState app m, HasMongoDB app)
+eitherWithDB' :: (MonadIO m, MonadState app m, HasMongoDB app, MonadBaseControl IO m)
               => AccessMode             -- ^ Access mode you want to use when performing the action.
-              -> Action IO a            -- ^ 'Action' you want to perform.
+              -> Action m a            -- ^ 'Action' you want to perform.
               -> m (Either Failure a)   -- ^ 'Either' 'Failure' or the action's result.
 eitherWithDB' mode action = do
     (MongoDB pool database _) <- gets getMongoDB
-    ep <- liftIO $ runErrorT $ aResource pool
-    case ep of
-         Left  err -> return $ Left $ ConnectionFailure err
-         Right pip -> liftIO $ access pip mode database action
+    r <- tryWithResource pool (\pip -> access pip mode database action)
+    case r of
+      Just a -> return $ Right a
+      Nothing -> return $ Left $ ConnectionFailure $ userError "can not find pool resource"
 
 getMongoAccessMode :: (MonadIO m, MonadState app m, HasMongoDB app) => m AccessMode
 getMongoAccessMode = mongoAccessMode `liftM` gets getMongoDB

stack.yaml

@@ -0,0 +1,8 @@
+resolver: lts-3.22
+packages:
+- '.'
+
+extra-deps: []
+flags: {}
+extra-package-dbs: []
+