snaplet-mongodb-minimalistic (empty) → 0.0.1

raw patch · 6 files changed

+195/−0 lines, 6 filesdep +basedep +mongoDBdep +mtlsetup-changed

Dependencies added: base, mongoDB, mtl, snap, snap-core, text

Files

LICENSE +29/−0
Setup.hs +3/−0
snaplet-mongodb-minimalistic.cabal +50/−0
src/Snap/Snaplet/MongoDB.hs +7/−0
src/Snap/Snaplet/MongoDB/Core.hs +44/−0
src/Snap/Snaplet/MongoDB/Functions.hs +62/−0

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

+ snaplet-mongodb-minimalistic.cabal view

@@ -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++

+ src/Snap/Snaplet/MongoDB.hs view

@@ -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

+ src/Snap/Snaplet/MongoDB/Core.hs view

@@ -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

+ src/Snap/Snaplet/MongoDB/Functions.hs view

@@ -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