Skip to content

Commit

Permalink
Merge pull request #9 from zopa/master
Browse files Browse the repository at this point in the history 
Modify to work with snap-0.10
  • Loading branch information
@Palmik
Palmik committed Jan 2, 2013
2 parents 014fc12 + b4c8335 commit 0627e27
Show file tree
Hide file tree
Showing 3 changed files with 31 additions and 31 deletions.
3 changes: 2 additions & 1 deletion snaplet-mongodb-minimalistic.cabal
View file
Expand Up @@ -33,8 +33,9 @@ Library


Build-depends: Build-depends:
base == 4.*, base == 4.*,
lens == 3.7.*,
mtl == 2.*, mtl == 2.*,
snap == 0.9.*, snap == 0.10.*,
snap-core == 0.9.*, snap-core == 0.9.*,
text == 0.11.*, text == 0.11.*,
mongoDB == 1.3.* mongoDB == 1.3.*
Expand Down
58 changes: 29 additions & 29 deletions src/Snap/Snaplet/MongoDB/Functions/M.hs
View file
Expand Up @@ -15,27 +15,26 @@ module Snap.Snaplet.MongoDB.Functions.M
) where ) where


import Control.Monad.Error (runErrorT) import Control.Monad.Error (runErrorT)
import Control.Lens (cloneLens, use)


import Snap (MonadIO, MonadState, gets, liftIO) -- transformers, mtl import Snap (MonadIO, MonadState, gets, liftIO) -- transformers, mtl
import Snap (Lens, getL) -- data-lens import Snap (SnapletLens)
import Snap (Snaplet, snapletValue) import Snap (Snaplet, snapletValue)
import Snap.Snaplet.MongoDB.Core import Snap.Snaplet.MongoDB.Core


import Database.MongoDB (Action, AccessMode, Failure (ConnectionFailure), access) import Database.MongoDB (Action, AccessMode, Failure (ConnectionFailure), access)
import System.IO.Pool (aResource) import System.IO.Pool (aResource)


import qualified Control.Category as C ((.))

------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Database access function. -- | Database access function.
-- --
-- Example: -- Example:
-- --
-- > unsafeWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ] -- > unsafeWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ]
unsafeWithDB :: (MonadIO m, MonadState app m) unsafeWithDB :: (MonadIO m, MonadState app m)
=> Lens app (Snaplet MongoDB) -- ^ The snaplet (database) on which you want the action to be run. => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
-> Action IO a -- ^ 'Action' you want to perform. -> Action IO a -- ^ 'Action' you want to perform.
-> m a -- ^ The action's result; in case of failure 'error' is called. -> m a -- ^ The action's result; in case of failure 'error' is called.
unsafeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (unsafeWithDB' snaplet) action unsafeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (unsafeWithDB' snaplet) action


------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Expand All @@ -45,10 +44,10 @@ unsafeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (unsafeWithDB'
-- --
-- > unsafeWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ] -- > unsafeWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
unsafeWithDB' :: (MonadIO m, MonadState app m) unsafeWithDB' :: (MonadIO m, MonadState app m)
=> Lens app (Snaplet MongoDB) -- ^ The snaplet (database) on which you want the action to be run. => 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. -> AccessMode -- ^ Access mode you want to use when performing the action.
-> Action IO a -- ^ 'Action' you want to perform. -> Action IO a -- ^ 'Action' you want to perform.
-> m a -- ^ The action's result; in case of failure 'error' is called. -> m a -- ^ The action's result; in case of failure 'error' is called.
unsafeWithDB' snaplet mode action = do unsafeWithDB' snaplet mode action = do
res <- (eitherWithDB' snaplet mode action) res <- (eitherWithDB' snaplet mode action)
either (error . show) return res either (error . show) return res
Expand All @@ -60,9 +59,9 @@ unsafeWithDB' snaplet mode action = do
-- --
-- > maybeWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ] -- > maybeWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ]
maybeWithDB :: (MonadIO m, MonadState app m) maybeWithDB :: (MonadIO m, MonadState app m)
=> Lens app (Snaplet MongoDB) -- ^ The snaplet (database) on which you want the action to be run. => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
-> Action IO a -- ^ 'Action' you want to perform. -> Action IO a -- ^ 'Action' you want to perform.
-> m (Maybe a) -- ^ 'Nothing' in case of failure or 'Just' the result of the action. -> m (Maybe a) -- ^ 'Nothing' in case of failure or 'Just' the result of the action.
maybeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (maybeWithDB' snaplet) action maybeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (maybeWithDB' snaplet) action


------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Expand All @@ -72,10 +71,10 @@ maybeWithDB snaplet action = getMongoAccessMode snaplet >>= flip (maybeWithDB' s
-- --
-- > maybeWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ] -- > maybeWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
maybeWithDB' :: (MonadIO m, MonadState app m) maybeWithDB' :: (MonadIO m, MonadState app m)
=> Lens app (Snaplet MongoDB) -- ^ The snaplet (database) on which you want the action to be run. => 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. -> AccessMode -- ^ Access mode you want to use when performing the action.
-> Action IO a -- ^ 'Action' you want to perform. -> Action IO a -- ^ 'Action' you want to perform.
-> m (Maybe a) -- ^ 'Nothing' in case of failure or 'Just' the result of the action. -> m (Maybe a) -- ^ 'Nothing' in case of failure or 'Just' the result of the action.
maybeWithDB' snaplet mode action = do maybeWithDB' snaplet mode action = do
res <- (eitherWithDB' snaplet mode action) res <- (eitherWithDB' snaplet mode action)
return $ either (const Nothing) Just res return $ either (const Nothing) Just res
Expand All @@ -87,9 +86,9 @@ maybeWithDB' snaplet mode action = do
-- --
-- > eitherWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ] -- > eitherWithDB accountDB $ insert "test-collection" [ "some_field" = "something" ]
eitherWithDB :: (MonadIO m, MonadState app m) eitherWithDB :: (MonadIO m, MonadState app m)
=> Lens app (Snaplet MongoDB) -- ^ The snaplet (database) on which you want the action to be run. => SnapletLens app MongoDB -- ^ The snaplet (database) on which you want the action to be run.
-> Action IO a -- ^ 'Action' you want to perform. -> Action IO a -- ^ 'Action' you want to perform.
-> m (Either Failure a) -- ^ 'Either' 'Failure' or the action's result. -> m (Either Failure a) -- ^ 'Either' 'Failure' or the action's result.
eitherWithDB snaplet action = getMongoAccessMode snaplet >>= flip (eitherWithDB' snaplet) action eitherWithDB snaplet action = getMongoAccessMode snaplet >>= flip (eitherWithDB' snaplet) action


------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Expand All @@ -99,19 +98,20 @@ eitherWithDB snaplet action = getMongoAccessMode snaplet >>= flip (eitherWithDB'
-- --
-- > eitherWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ] -- > eitherWithDB' accountDB UnconfirmedWrites $ insert "test-collection" [ "some_field" = "something" ]
eitherWithDB' :: (MonadIO m, MonadState app m) eitherWithDB' :: (MonadIO m, MonadState app m)
=> Lens app (Snaplet MongoDB) -- ^ The snaplet (database) on which you want the action to be run. => 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. -> AccessMode -- ^ Access mode you want to use when performing the action.
-> Action IO a -- ^ 'Action' you want to perform. -> Action IO a -- ^ 'Action' you want to perform.
-> m (Either Failure a) -- ^ 'Either' 'Failure' or the action's result. -> m (Either Failure a) -- ^ 'Either' 'Failure' or the action's result.
eitherWithDB' snaplet mode action = do eitherWithDB' snaplet mode action = do
(MongoDB pool database _) <- gets (getL ((C..) snapletValue snaplet)) (MongoDB pool database _) <- use (snaplet'.snapletValue)
ep <- liftIO $ runErrorT $ aResource pool ep <- liftIO $ runErrorT $ aResource pool
case ep of case ep of
Left err -> return $ Left $ ConnectionFailure err Left err -> return $ Left $ ConnectionFailure err
Right pip -> liftIO $ access pip mode database action Right pip -> liftIO $ access pip mode database action
where
snaplet' = cloneLens snaplet


getMongoAccessMode :: (MonadIO m, MonadState app m) => Lens app (Snaplet MongoDB) -> m AccessMode getMongoAccessMode :: (MonadIO m, MonadState app m) => SnapletLens app MongoDB -> m AccessMode
getMongoAccessMode snaplet = gets (getL ((C..) snapletValue snaplet)) >>= return . mongoAccessMode getMongoAccessMode snaplet = use (snaplet'.snapletValue) >>= return . mongoAccessMode
where snaplet' = cloneLens snaplet
{-# INLINE getMongoAccessMode #-} {-# INLINE getMongoAccessMode #-}


1 change: 0 additions & 1 deletion src/Snap/Snaplet/MongoDB/Functions/S.hs
View file
Expand Up @@ -17,7 +17,6 @@ module Snap.Snaplet.MongoDB.Functions.S
import Control.Monad.Error (runErrorT) import Control.Monad.Error (runErrorT)


import Snap (MonadIO, MonadState, gets, liftIO) -- transformers, mtl import Snap (MonadIO, MonadState, gets, liftIO) -- transformers, mtl
import Snap (Lens, getL) -- data-lens
import Snap (Snaplet, snapletValue) import Snap (Snaplet, snapletValue)
import Snap.Snaplet.MongoDB.Core import Snap.Snaplet.MongoDB.Core


Expand Down

0 comments on commit 0627e27

Please sign in to comment.