wheb-mongo 0.0.1.0 → 0.0.2.0
raw patch · 2 files changed
+70/−60 lines, 2 filesdep ~Whebdep ~basedep ~bson
Dependency ranges changed: Wheb, base, bson, mongoDB, mtl, text
Files
- Web/Wheb/Plugins/Mongo.hs +18/−57
- wheb-mongo.cabal +52/−3
Web/Wheb/Plugins/Mongo.hs view
@@ -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)
wheb-mongo.cabal view
@@ -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 <http://hackage.haskell.org/package/Wheb Wheb> + . * Creates simple interface for arbitrary MongoDB actions using <http://hackage.haskell.org/package/mongoDB mongoDB> . For a complete example, see the examples folder at <https://github.com/hansonkd/Wheb-Framework/tree/master/examples github>+ . + 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