apiary-mongoDB (empty) → 0.17.0.0
raw patch · 4 files changed
+178/−0 lines, 4 filesdep +apiarydep +basedep +bsonsetup-changed
Dependencies added: apiary, base, bson, data-default-class, lifted-base, monad-control, mongoDB, resource-pool, text, time, transformers
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- apiary-mongoDB.cabal +38/−0
- src/Web/Apiary/MongoDB.hs +118/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Hirotomo Moriwaki++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ apiary-mongoDB.cabal view
@@ -0,0 +1,38 @@+name: apiary-mongoDB+version: 0.17.0.0+synopsis: mongoDB support for apiary web framework.+-- description:+license: MIT+license-file: LICENSE+author: HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer: HirotomoMoriwaki<philopon.dependence@gmail.com>+Homepage: https://github.com/philopon/apiary+Bug-reports: https://github.com/philopon/apiary/issues+copyright: (c) 2014 Hirotomo Moriwaki+category: Web+build-type: Simple+stability: experimental+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Web.Apiary.MongoDB+ other-modules: + build-depends: base >=4.6 && <4.8+ , apiary >=0.17 && <0.18+ , mongoDB >=2.0 && <2.1+ , resource-pool >=0.2 && <0.3+ , data-default-class >=0.0 && <0.1+ , transformers >=0.2 && <0.5+ , time >=1.4 && <1.6+ , lifted-base >=0.2 && <0.3+ , bson >=0.3 && <0.4+ , monad-control >=0.3 && <0.4+ , text >=1.1 && <1.3+ hs-source-dirs: src+ ghc-options: -O2 -Wall+ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/philopon/apiary.git
+ src/Web/Apiary/MongoDB.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}++module Web.Apiary.MongoDB+ ( MongoDB, MongoDBConfig(..), MongoQuery+ -- * initializer+ , initMongoDB, initHerokuMongoDB+ -- * query+ , access+ -- * reexports+ , module Data.Bson+ , module Database.MongoDB.Connection+ , module Database.MongoDB.Query+ , module Database.MongoDB.Admin+ ) where++import Control.Arrow+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Exception.Lifted++import Web.Apiary+import Web.Apiary.Heroku++import qualified Database.MongoDB as MongoDB++import Data.Default.Class+import Data.Time(NominalDiffTime)+import Data.Pool+import Data.Apiary.Proxy+import Data.Apiary.Extension+import qualified Data.Text as T+import qualified Data.Text.Read as T++import Data.Bson+import Database.MongoDB.Connection hiding (close, isClosed, connect, connect')+import Database.MongoDB.Query hiding (Query, access)+import Database.MongoDB.Admin++type MongoQuery = MongoDB.Query++data MongoDB = MongoDB (Pool Pipe) MongoDBConfig++data MongoDBConfig = MongoDBConfig+ { mongoDBTimeout :: Secs+ , mongoDBHost :: Host+ , mongoDBAuth :: Maybe (Username, Password)+ , mongoDBDatabase :: Database+ , mongoDBAccessMode :: AccessMode+ , numConnection :: Int+ , connectionIdleTime :: NominalDiffTime+ }++instance Default MongoDBConfig where+ def = MongoDBConfig 6 (host "localhost") Nothing "" master 1 20++initMongoDB' :: (MonadBaseControl IO m, MonadIO m)+ => MongoDBConfig -> (MongoDB -> m a) -> m a+initMongoDB' conf@MongoDBConfig{..} m =+ bracket (liftIO bra) (liftIO . destroyAllResources) (\a -> m (MongoDB a conf))+ where+ bra = createPool (MongoDB.connect' mongoDBTimeout mongoDBHost)+ MongoDB.close 1 connectionIdleTime numConnection++initMongoDB :: (MonadIO m, MonadBaseControl IO m)+ => MongoDBConfig -> Initializer' m MongoDB+initMongoDB conf = initializerBracket' (initMongoDB' conf)++getMongoDBConfig :: T.Text -> MongoDBConfig -> MongoDBConfig+getMongoDBConfig s0 cfg =+ let (_, s1) = T.breakOnEnd "://" s0+ (user, s2) = T.break (== ':') s1+ (passwd, s3) = T.break (== '@') (T.tail s2)+ (host_, s4) = first T.unpack $ T.break (== ':') (T.tail s3)+ (port, s5) = T.break (== '/') (T.tail s4)+ db = if T.null s5 then "" else T.tail s5+ in cfg { mongoDBHost = either (const $ host host_) (Host host_ . PortNumber . fst) (T.decimal port) + , mongoDBAuth = Just (user, passwd)+ , mongoDBDatabase = db+ }++-- | initialize MongoDB extension using heroku service.+-- +-- compatible:+--+-- * MongoHQ+-- * MongoLab+-- * MongoSoup+initHerokuMongoDB :: (MonadIO m, MonadBaseControl IO m, Has Heroku exts)+ => MongoDBConfig -> Initializer m exts (MongoDB ': exts)+initHerokuMongoDB conf = initializerBracket $ \exts m -> do+ let hc = getExtension Proxy exts+ mbConn <- liftIO . runMaybeT $+ MaybeT (getHerokuEnv' "MONGOHQ_URL" hc) <|>+ MaybeT (getHerokuEnv' "MONGOLAB_URI" hc) <|>+ MaybeT (getHerokuEnv' "MONGOSOUP_URL" hc)+ let conf' = maybe conf (flip getMongoDBConfig conf) mbConn+ initMongoDB' conf' m++-- | query using 'MongoDBConfig' settings.+--+-- if you want to access other db, other accessmode, please use 'useDb' or 'accessMode'.+access :: (Has MongoDB exts, MonadBaseControl IO m, MonadIO m)+ => Action (ActionT exts m) a -> ActionT exts m a+access m = do+ MongoDB mongo conf <- getExt (Proxy :: Proxy MongoDB)+ withResource mongo $ \p ->+ MongoDB.access p (mongoDBAccessMode conf) (mongoDBDatabase conf) $+ maybe (return True) (uncurry auth) (mongoDBAuth conf)+ >>= flip unless (throwIO $ ConnectionFailure $ userError "auth failed.")+ >> m