Initial Commit.

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.

Setup.hs

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

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

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

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

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