wheb-mongo (empty) → 0.0.1.0
raw patch · 4 files changed
+218/−0 lines, 4 filesdep +Whebdep +basedep +bsonsetup-changed
Dependencies added: Wheb, base, bson, mongoDB, mtl, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Web/Wheb/Plugins/Mongo.hs +162/−0
- wheb-mongo.cabal +24/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Kyle Hanson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kyle Hanson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Wheb/Plugins/Mongo.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Basic implementation of MongoDB connection.++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 (+ runAction+ , initMongo+ , catchResult+ , MongoApp (..)+ , MongoContainer+ , module Database.MongoDB+ ) where++import Control.Monad+import Control.Monad.Error (throwError)+import Data.Bson as B+import qualified Data.Text.Lazy as T+import Database.MongoDB+import Web.Wheb+import Web.Wheb.Plugins.Session+import Web.Wheb.Plugins.Auth++data MongoContainer = MongoContainer Pipe AccessMode Database++class MongoApp a where+ getMongoContainer :: a -> MongoContainer++instance MongoApp a => SessionApp a where+ getSessionContainer = SessionContainer . getMongoContainer++instance MongoApp a => AuthApp a where+ getAuthContainer = AuthContainer . getMongoContainer++instance SessionBackend MongoContainer where+ backendSessionPut sessId key content mc = mvoid $ do+ collectionName <- getSessionCollection+ runWithContainer mc $ do+ insert_ collectionName [ "sessId" := (toBsonString sessId)+ , "key" := (toBsonString key)+ , "content" := (toBsonString content) ]+ backendSessionGet sessId key mc = do+ collectionName <- getSessionCollection+ 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+ collectionName <- getSessionCollection+ runWithContainer mc $+ delete (select ["sessId" := (toBsonString sessId), "key" := (toBsonString key)] collectionName)+ backendSessionClear sessId mc = mvoid $ do+ collectionName <- getSessionCollection+ runWithContainer mc $+ delete (select ["sessId" := (toBsonString sessId)] collectionName)++instance AuthBackend MongoContainer where+ backendGetUser name mc = do+ collectionName <- getAuthCollection+ catchResult $ runWithContainer mc $ do+ n <- next =<< find (select ["username" := (toBsonString name)] collectionName)+ return $ maybe Nothing (const $ Just $ AuthUser name) n+ backendLogin name pw mc = do+ collectionName <- getAuthCollection+ passCheck <- catchResult $ runWithContainer mc $ do+ n <- next =<< find (select ["username" := (toBsonString name)] collectionName)+ return $ maybe Nothing (\doc -> fmap (verifyPw pw . T.fromStrict) (B.lookup "password" doc)) n+ case passCheck of+ Just True -> return (Right $ AuthUser $ name)+ Just False -> return (Left InvalidPassword)+ Nothing -> return (Left UserDoesNotExist)+ backendRegister user@(AuthUser name) pw mc = do+ collectionName <- getAuthCollection+ pwHash <- makePwHash pw+ catchResult $ runWithContainer mc $ do+ n <- next =<< find (select ["username" := (toBsonString name)] collectionName)+ case n of+ Just _ -> return (Left DuplicateUsername)+ Nothing -> do+ insert_ collectionName [ "username" := (toBsonString name)+ , "password" := (toBsonString pwHash)]+ return (Right user)+ backendLogout _ = getUserSessionKey >>= deleteSessionValue++toBsonString = val . T.toStrict++-- | 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++mvoid :: Monad m => WhebT g s m (Either Failure b) -> WhebT g s m ()+mvoid m = catchResult m >> return ()++getSessionCollection :: Monad m => WhebT g s m Collection+getSessionCollection = liftM T.toStrict (getSetting'' "session-collection" "sessions")++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 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)++-- | 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)+ addCleanupHook $ close pipe+ return $ MongoContainer pipe master (T.toStrict db)
+ wheb-mongo.cabal view
@@ -0,0 +1,24 @@+name: wheb-mongo+version: 0.0.1.0+synopsis: MongoDB plugin for Wheb+homepage: https://github.com/hansonkd/Wheb-Framework+license: BSD3+license-file: LICENSE+author: Kyle Hanson+maintainer: hanooter@gmail.com+category: Database+build-type: Simple+cabal-version: >=1.8+description: + Wheb plugin for MongoDB.+ .+ * Implements SessionBackend and AuthBackend instances using Mongo.+ .+ * 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>++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.*+