diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/snaplet-mongodb-minimalistic.cabal b/snaplet-mongodb-minimalistic.cabal new file mode 100644 --- /dev/null +++ b/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 + + diff --git a/src/Snap/Snaplet/MongoDB.hs b/src/Snap/Snaplet/MongoDB.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Snap/Snaplet/MongoDB/Core.hs b/src/Snap/Snaplet/MongoDB/Core.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Snap/Snaplet/MongoDB/Functions.hs b/src/Snap/Snaplet/MongoDB/Functions.hs new file mode 100644 --- /dev/null +++ b/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