Permalink
Browse files

Initial Commit.

  • Loading branch information...
0 parents commit fd9018f9820db424229fddff62b065df4081ec49 @Palmik committed Jan 15, 2012
29 LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2012, Petr Pilař
+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 Petr Pilař 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.
0 README
No changes.
3 Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
BIN dist/snaplet-mongodb-minimalistic-0.0.1.tar.gz
Binary file not shown.
50 snaplet-mongodb-minimalistic.cabal
@@ -0,0 +1,50 @@
+name: snaplet-mongodb-minimalistic
+version: 0.0.1
+synopsis: Minimalistic MongoDB Snaplet.
+description: Minimalistic MongoDB Snaplet.
+license: BSD3
+license-file: LICENSE
+author: Petr Pilař
+maintainer: the.palmik+maintainer@gmail.com
+build-type: Simple
+cabal-version: >= 1.6
+homepage: https://github.com/Palmik/snaplet-mongodb-minimalistic
+category: Web
+
+Flag development
+ Description: Whether to build the server in development (interpreted) mode
+ Default: False
+
+Library
+ hs-source-dirs: src
+
+ Exposed-modules:
+ Snap.Snaplet.MongoDB,
+ Snap.Snaplet.MongoDB.Core,
+ Snap.Snaplet.MongoDB.Functions
+
+ Build-depends:
+ base >= 4 && < 5,
+ mtl >= 2 && < 3,
+ snap == 0.7.*,
+ snap-core == 0.7.*,
+ text >= 0.11 && < 0.12,
+ mongoDB >= 1.1.1 && < 1.2.0
+
+ if flag(development)
+ cpp-options: -DDEVELOPMENT
+ -- In development mode, speed is already going to suffer, so skip
+ -- the fancy optimization flags. Additionally, disable all
+ -- warnings. The hint library doesn't give an option to execute
+ -- compiled code when there were also warnings, so disabling
+ -- warnings allows quicker workflow.
+ ghc-options: -w
+ else
+ if impl(ghc >= 6.12.0)
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
+ -fno-warn-orphans -fno-warn-unused-do-bind
+ else
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
+ -fno-warn-orphans
+
+
7 src/Snap/Snaplet/MongoDB.hs
@@ -0,0 +1,7 @@
+module Snap.Snaplet.MongoDB
+( module Snap.Snaplet.MongoDB.Core
+, module Snap.Snaplet.MongoDB.Functions
+) where
+
+import Snap.Snaplet.MongoDB.Core
+import Snap.Snaplet.MongoDB.Functions
44 src/Snap/Snaplet/MongoDB/Core.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Snap.Snaplet.MongoDB.Core
+( MongoDB(..)
+, HasMongoDB(..)
+, mongoDBInit
+) where
+
+import Data.Text (Text)
+
+import Snap
+
+import Database.MongoDB
+import System.IO.Pool
+
+------------------------------------------------------------------------------
+-- |
+description :: Text
+description = "Minimalistic MongoDB Snaplet"
+
+------------------------------------------------------------------------------
+-- |
+data MongoDB = MongoDB
+ { mongoPool :: Pool IOError Pipe
+ , mongoDatabase :: Database
+ }
+
+------------------------------------------------------------------------------
+-- |
+class HasMongoDB app where
+ getMongoDB :: app -> MongoDB
+
+------------------------------------------------------------------------------
+-- |
+mongoDBInit :: Int -> Host -> Database -> SnapletInit app MongoDB
+mongoDBInit n h d = makeSnaplet "snaplet-mongodb" description Nothing $ do
+ pool <- liftIO $ newPool (Factory (connect h) close isClosed) n
+ return $ MongoDB pool d
62 src/Snap/Snaplet/MongoDB/Functions.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Snap.Snaplet.MongoDB.Functions
+( eitherWithDB'
+, eitherWithDB
+, maybeWithDB
+, maybeWithDB'
+, unsafeWithDB
+, unsafeWithDB'
+) where
+
+import Control.Monad.Error
+
+import Snap
+import Snap.Snaplet.MongoDB.Core
+
+import Database.MongoDB
+import System.IO.Pool
+
+class (MonadIO m, MonadState app m, HasMongoDB app) => HasMongoDB' app m
+instance (MonadIO m, MonadState app m, HasMongoDB app) => HasMongoDB' app m
+
+------------------------------------------------------------------------------
+-- |
+unsafeWithDB :: (HasMongoDB' app m) => Action IO a -> m a
+unsafeWithDB = unsafeWithDB' UnconfirmedWrites
+
+------------------------------------------------------------------------------
+-- |
+unsafeWithDB' :: (HasMongoDB' app m) => AccessMode -> Action IO a -> m a
+unsafeWithDB' mode action = do
+ res <- (eitherWithDB' mode action)
+ return $ either (error . show) id res
+
+------------------------------------------------------------------------------
+-- |
+maybeWithDB :: (HasMongoDB' app m) => Action IO a -> m (Maybe a)
+maybeWithDB = maybeWithDB' UnconfirmedWrites
+
+------------------------------------------------------------------------------
+-- |
+maybeWithDB' :: (HasMongoDB' app m) => AccessMode -> Action IO a -> m (Maybe a)
+maybeWithDB' mode action = do
+ res <- (eitherWithDB' mode action)
+ return $ either (const Nothing) Just res
+
+------------------------------------------------------------------------------
+-- |
+eitherWithDB :: (HasMongoDB' app m) => Action IO a -> m (Either Failure a)
+eitherWithDB = eitherWithDB' UnconfirmedWrites
+
+------------------------------------------------------------------------------
+-- |
+eitherWithDB' :: (HasMongoDB' app m) => AccessMode -> Action IO a -> m (Either Failure a)
+eitherWithDB' mode action = do
+ (MongoDB pool database) <- gets getMongoDB
+ ep <- liftIO $ runErrorT $ aResource pool
+ case ep of
+ Left err -> return $ Left $ ConnectionFailure err
+ Right pip -> liftIO $ access pip mode database action

0 comments on commit fd9018f

Please sign in to comment.