diff --git a/Web/Wheb/Plugins/Mongo.hs b/Web/Wheb/Plugins/Mongo.hs --- a/Web/Wheb/Plugins/Mongo.hs +++ b/Web/Wheb/Plugins/Mongo.hs @@ -7,46 +7,6 @@ Adds default instances for 'SessionApp' and 'AuthApp' for 'MongoApp'. -You can override the collection names for the Auth and Session documents by using 'addSetting' and setting keys for \"session-collection\" -and \"auth-collection\" - -> opts <- generateOptions $ do -> addSetting "session-collection" "my-collection" - -Reimplimentation of official example below. Use with language extensions /OvererloadedStrings/ & /ExtendedDefaultRules/. - -> import qualified Data.Text.Lazy as T -> -> import Web.Wheb -> import Web.Wheb.Plugins.Mongo -> -> data MyApp = MyApp MongoContainer -> data MyRequestState = MyRequestState -> -> instance MongoApp MyApp where -> getMongoContainer (MyApp mc) = mc -> -> homePage :: WhebHandler MyApp MyRequestState -> homePage = do -> mongoRes <- runAction $ do -> delete (select [] "team") -> insertMany "team" [ -> ["name" =: "Yankees", "home" =: ["city" =: "New York", "state" =: "NY"], "league" =: "American"], -> ["name" =: "Mets", "home" =: ["city" =: "New York", "state" =: "NY"], "league" =: "National"], -> ["name" =: "Phillies", "home" =: ["city" =: "Philadelphia", "state" =: "PA"], "league" =: "National"], -> ["name" =: "Red Sox", "home" =: ["city" =: "Boston", "state" =: "MA"], "league" =: "American"] ] -> rest =<< find (select [] "team") {sort = ["home.city" =: 1]} -> case mongoRes of -> Left err -> text $ spack err -> Right teams -> text $ T.intercalate " | " $ map spack teams -> -> main :: IO () -> main = do -> opts <- generateOptions $ do -> addGET "." rootPat $ homePage -> mongo <- initMongo "127.0.0.1:27017" "master" -> return (MyApp mongo, MyRequestState) -> runWhebServer opts -} module Web.Wheb.Plugins.Mongo ( @@ -58,8 +18,9 @@ , module Database.MongoDB ) where +import Control.Exception import Control.Monad -import Control.Monad.Error (throwError) +import Control.Monad.Except (throwError) import Data.Bson as B import qualified Data.Text.Lazy as T import Database.MongoDB @@ -79,9 +40,9 @@ getAuthContainer = AuthContainer . getMongoContainer instance SessionBackend MongoContainer where - backendSessionPut sessId key content mc = mvoid $ do + backendSessionPut sessId key content mc = do collectionName <- getSessionCollection - runWithContainer mc $ do + mvoid $ runWithContainer mc $ do insert_ collectionName [ "sessId" := (toBsonString sessId) , "key" := (toBsonString key) , "content" := (toBsonString content) ] @@ -90,13 +51,13 @@ catchResult $ runWithContainer mc $ do n <- next =<< find (select ["sessId" := (toBsonString sessId), "key" := (toBsonString key)] collectionName) return $ maybe Nothing ((fmap T.fromStrict) . (B.lookup (T.toStrict key))) n - backendSessionDelete sessId key mc = mvoid $ do + backendSessionDelete sessId key mc = do collectionName <- getSessionCollection - runWithContainer mc $ + mvoid $ runWithContainer mc $ delete (select ["sessId" := (toBsonString sessId), "key" := (toBsonString key)] collectionName) - backendSessionClear sessId mc = mvoid $ do + backendSessionClear sessId mc = do collectionName <- getSessionCollection - runWithContainer mc $ + mvoid $ runWithContainer mc $ delete (select ["sessId" := (toBsonString sessId)] collectionName) instance AuthBackend MongoContainer where @@ -129,11 +90,14 @@ toBsonString = val . T.toStrict +handleEither :: Monad m => Either Failure b -> WhebT g s m b +handleEither = either (throwError . Error500 . show) return + -- | Push an error from Mongo to a 500 Error. -catchResult :: Monad m => WhebT g s m (Either Failure b) -> WhebT g s m b -catchResult m = m >>= either (throwError . Error500 . show) return +catchResult :: MonadIO m => IO b -> WhebT g s m b +catchResult m = (liftIO $ try m) >>= handleEither -mvoid :: Monad m => WhebT g s m (Either Failure b) -> WhebT g s m () +mvoid :: MonadIO m => IO b -> WhebT g s m () mvoid m = catchResult m >> return () getSessionCollection :: Monad m => WhebT g s m Collection @@ -142,21 +106,18 @@ getAuthCollection :: Monad m => WhebT g s m Collection getAuthCollection = liftM T.toStrict (getSetting'' "auth-collection" "users") -runMaybeContainer :: MonadIO m => MongoContainer -> Action IO a -> WhebT g s m (Maybe a) -runMaybeContainer m a = liftM (either (const Nothing) Just) (runWithContainer m a) - -runWithContainer :: (MonadIO m) => MongoContainer -> Action IO a -> WhebT g s m (Either Failure a) +runWithContainer :: MongoContainer -> Action IO a -> IO a runWithContainer (MongoContainer pipe mode db) action = liftIO $ access pipe mode db action -- | Run a MongoDB Action Monad in WhebT runAction :: (MongoApp g, MonadIO m) => Action IO a -> - WhebT g s m (Either Failure a) -runAction action = (getWithApp getMongoContainer) >>= (flip runWithContainer action) + WhebT g s m a +runAction action = (getWithApp getMongoContainer) >>= (\c -> liftIO $ runWithContainer c action) -- | Initialize mongo with \"host:post\" and default database. initMongo :: T.Text -> T.Text -> InitM g s m MongoContainer initMongo host db = do - pipe <- liftIO $ runIOE $ connect (readHostPort $ T.unpack host) + pipe <- liftIO $ connect (readHostPort $ T.unpack host) addCleanupHook $ close pipe return $ MongoContainer pipe master (T.toStrict db) diff --git a/wheb-mongo.cabal b/wheb-mongo.cabal --- a/wheb-mongo.cabal +++ b/wheb-mongo.cabal @@ -1,5 +1,5 @@ name: wheb-mongo -version: 0.0.1.0 +version: 0.0.2.0 synopsis: MongoDB plugin for Wheb homepage: https://github.com/hansonkd/Wheb-Framework license: BSD3 @@ -12,13 +12,62 @@ description: Wheb plugin for MongoDB. . - * Implements SessionBackend and AuthBackend instances using Mongo. + * Implements SessionBackend and AuthBackend instances using MongoDB and Wheb. . + * Creates simple interface for arbitrary MongoDB actions using + . * Creates simple interface for arbitrary MongoDB actions using . For a complete example, see the examples folder at + . + You can override the collection names for the Auth and Session documents by using 'addSetting' and setting keys for \"session-collection\" + and \"auth-collection\" + . + > opts <- generateOptions $ do + > addSetting "session-collection" "my-collection" + . + Reimplimentation of official example below. Use with language extensions /OvererloadedStrings/ & /ExtendedDefaultRules/. + . + > import qualified Data.Text.Lazy as T + > + > import Web.Wheb + > import Web.Wheb.Plugins.Mongo + > + > data MyApp = MyApp MongoContainer + > data MyRequestState = MyRequestState + > + > instance MongoApp MyApp where + > getMongoContainer (MyApp mc) = mc + > + > homePage :: WhebHandler MyApp MyRequestState + > homePage = do + > teams <- runAction $ rest =<< find (select [] "team") + > text $ T.intercalate " | " $ map spack teams + > + > main :: IO () + > main = do + > opts <- generateOptions $ do + > addGET "." rootPat $ homePage + > mongo <- initMongo "127.0.0.1:27017" "master" + > return (MyApp mongo, MyRequestState) + > + > runRawHandler opts $ do + > runAction $ do + > delete (select [] "team") + > insertMany "team" [ + > ["name" =: "Yankees", "home" =: ["city" =: "New York", "state" =: "NY"], "league" =: "American"], + > ["name" =: "Mets", "home" =: ["city" =: "New York", "state" =: "NY"], "league" =: "National"], + > ["name" =: "Phillies", "home" =: ["city" =: "Philadelphia", "state" =: "PA"], "league" =: "National"], + > ["name" =: "Red Sox", "home" =: ["city" =: "Boston", "state" =: "MA"], "league" =: "American"] ] + > + > runWhebServer opts library exposed-modules: Web.Wheb.Plugins.Mongo - build-depends: base ==4.6.*, text ==0.11.*, mongoDB ==1.4.*, Wheb ==0.1.*, bson ==0.2.2, mtl == 2.1.* + build-depends: base >=4.7 && <4.8, + text >= 1.0 && < 1.2, + mongoDB >=2.0 && < 2.1, + Wheb >=0.2 && < 0.3, + bson >=0.3 && <0.4, + mtl >= 2.1 && < 2.3