From fd9018f9820db424229fddff62b065df4081ec49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Petr=20Pila=C5=99?= Date: Sun, 15 Jan 2012 10:23:41 +0100 Subject: [PATCH] Initial Commit. --- LICENSE | 29 ++++++++ README | 0 Setup.hs | 3 + .../snaplet-mongodb-minimalistic-0.0.1.tar.gz | Bin 0 -> 2706 bytes snaplet-mongodb-minimalistic.cabal | 50 ++++++++++++++ src/Snap/Snaplet/MongoDB.hs | 7 ++ src/Snap/Snaplet/MongoDB/Core.hs | 44 +++++++++++++ src/Snap/Snaplet/MongoDB/Functions.hs | 62 ++++++++++++++++++ 8 files changed, 195 insertions(+) create mode 100644 LICENSE create mode 100644 README create mode 100644 Setup.hs create mode 100644 dist/snaplet-mongodb-minimalistic-0.0.1.tar.gz create mode 100644 snaplet-mongodb-minimalistic.cabal create mode 100644 src/Snap/Snaplet/MongoDB.hs create mode 100644 src/Snap/Snaplet/MongoDB/Core.hs create mode 100644 src/Snap/Snaplet/MongoDB/Functions.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4648791 --- /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. \ No newline at end of file diff --git a/README b/README new file mode 100644 index 0000000..e69de29 diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/dist/snaplet-mongodb-minimalistic-0.0.1.tar.gz b/dist/snaplet-mongodb-minimalistic-0.0.1.tar.gz new file mode 100644 index 0000000000000000000000000000000000000000..fef2f17a268a34ce04f92143200c81eca1b6fdc4 GIT binary patch literal 2706 zcmV;D3T^ctiwFP!000001MM2^a^g60e)}o9W~X*w4?Mtxq$;=BIs#7OD*~)-CO1EY zEkHH4<+Du^Zf_st9_Zfdx@8+oK1ec|WNP>5R6t0r{+7BWI|*6j^Rynwa3;M;JrJP? zm@kr4xb=qK(3>CLJQo@W2ko}{M!5N{+Rf%cW3S!ZJ7^!gX*An=`>i+7em3Vvz#>Um zjG{c3&Q0b1Ado!lf19U^NS`NP&4cW*zqfb4|Iz20{y%888gJlLjQD@3K{A)cKTe?0wzK@0*_DG!cWifm-fBI-N848N38#CD7wog%zuE#1MB}|v)SHU z|E;}N^I*6BUjsrG@IzR`HfL*>JWgOU@7ZW1*VWgOCT}((lpDaR`v`dKJv2umS zBOZD=w+Tx)+ym&6J^1lQ_!-(6hamOu!zJWahWs%@CjZ=rd~}2nf1v-g#;m)j$Ag$D zzfQLZfNQ9k$$+g^E_1#R?wQim@h_Xx)LVLk%p|5T#Zak~99~tl+$gF`6)fn(daq}E zGWx^OxiN6maJ>%ZW|&Z5)F6pC_dq1T{FpOu2{S3e8HHK0m`-_&7})$GqJj#=-IRsy z5{O$M{>6x=5-QOFI-Vz}gZcil2A)XR#OFxdFXmsdI7AMF>maE)1}pekFoGv}624Di zCN6PK2$?=448P{?BIN}UTxt<+3m!H+4p(y?l3eJdEBe3)mn%L>flLnkc~c6KOkO4M z&xLTm;8MDh@s}y~=n8Q*cS|44XJfi-~)9cssc%c4k9klmvod5RQjpnZYdkyHyXc>#y9E$_D3athvppCkzgZqOT zPax*1s_=A8v$$6}Fye;n0q!|eZe#_6>cQQIw(hBn1Kew`uoMCrt8ckTHB2&MDqNK# zYQS)Fj(8l16iX9`VtFY%PNfV>v%Df{H>UjK$}r0#iJBDf^iWg#(@(G|RRVHah@+B0 zfUZU*sMJ$5*+gE_P;P*HlM5wAKBm8Pj;W8<0g)*)4ZRx@Aye09BH*!ppCrh!WQ{@+ zRMT6abSq(U5mq8SU6`E0S|rGo^`yI??O9;S@oh%IKkoy_|vt1qx)!A+r?5 zpofxPt^}OoaAuoCPSY!jhdjKfdT}YfaH^oFiz%|gEXI-~)5AG4ZLo(Y&PB&E0NW#L z_{r=UJvjah&Y1z-;pnqvo}M{yHthEd%ZARNhrI*GGLOg3(6Y6+9UEu9RRf*DXE6RT zvJBgXp#|posBa=Mq;7Qvj%nC6FbCcKxMvPdYk&k`Fm$xOd2Tw0<_v3!>FsGSJb`n= z>Ym}x&av4yozIHjiRlc8*U8Y*Ixy;3j@cdeI~I(_)@W!OKx*|&yW8)W=SELQ?#L0a z{u?-8pLP2EO)a(I#lWyg^s}(s> zCrnZHU!gy=m9fUQQPX-Ir=u7n3A7XrWBYh)o62V9z%eXqJaWw8po;FjK&zmP9h}-z z#vKkwRg4j1XniK4WCLaU8eE(i*l&?Nm8Cjl0vj#Xb;@YS4-M#OYaL-=oc7IAW6(8d zbVyV#OxviUt4x~^OvM(Rk37dpWpWWprKx5qU~9^eV4gsy_sJx&b7XYAZRTO3Ox8Wi z&8^?w{~vSz6T8oQ2JrOz|NU0Gxx4>=4S1yg>45&#LGX0{A2i#$=RdCkPw{_#OY`J7 zc(VUnjrM+H=l|D$ukn9zOZV7Ef)AYk8m;{s=f75KuhHI}|6T*KOWZqeVYLcu8C6%f zT5T)J`Wm-NS8<51< z*#GyMH}C&idmr1o=fAH4ztw+$erIqx#^WKJFZ@)DSj+-v8S$>ql7uJlL;ZJc1MS4; z*J9#xGep~kE}{_JLK}x3cZJ6`F$qn3T+*mOcExmopS|Pvm~6_wDfh7Dgx~dxa2H|1 zrt8u2&-b_TQ3<+qH6?wLhk3dY$1=VPjl{mE`|iYc2Xc?4j2>mKGVUGpmPyJ3-5ly8 zDSb_I$th4#!kI$|YM`2S%2Ez2im2y|CB=hu?5V=hFQu;c8I~q;mwXFaTK$^>l7oM1 zWrxAxAyjVhRnl}+umH->p#BR4z&2+dZF(M~(v{&RR!S@p_j2n zX=y&im6dav2duh5;Amr|zm`Kccz(4%@6_lUyA{omq%e@_T!gbK{5^Zv@Iq!O3-=_~ z8kw{wO!$jfS!9FM(dOR&T3+5{`t@$!uH8KjuM|6Ngj+p$d2*;y5X^X*&_|Id)I5 zGeePXJA}~5KzHc9!3up=?>&Khn^VP0q|(xhzLZEwjg7t|c)RW0-?uL$6&h#7>IlmD z^ta48WD#W~6k4^-p~|Z;5>fVsM&ZRGw;^KDR^z|FjOf|XZ}UKwM-XvcR|g~zjbUOg z^n00-cpb~c(hO5#c_tI}y)qBBbDt_qlB^J`Od*6hc&fPn!gG9hdm}x)g>nStB`%g7 zc>$&BrgBXb@+;-S$_dsVGG40Un5r6>SHblqy|a{b>D#M9xLHnb7Gt}28+WjS9sJqg Mf7qkh?f^Uh0A2TFYybcN literal 0 HcmV?d00001 diff --git a/snaplet-mongodb-minimalistic.cabal b/snaplet-mongodb-minimalistic.cabal new file mode 100644 index 0000000..48bf8da --- /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 index 0000000..f650239 --- /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 \ No newline at end of file diff --git a/src/Snap/Snaplet/MongoDB/Core.hs b/src/Snap/Snaplet/MongoDB/Core.hs new file mode 100644 index 0000000..19c4c15 --- /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 index 0000000..e42cead --- /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 \ No newline at end of file