Permalink
Browse files

Add generics support, split project into modules

  • Loading branch information...
1 parent 71214d5 commit c499c6bfb7a333fdc0d0aa1e97c41ddd0dc15f1a @ozataman committed Mar 19, 2011
View
@@ -1,14 +1,67 @@
-Snap Extension for MongoDB
-==========================
+## Snap Extension for MongoDB
This package provides a straightforward way to integrate MongoDB database
connectivity into Snap applications.
The API is a work in progress, so expect changes.
-Starting with 0.3, this library provides out-of-box integration with Snap.Auth,
-but you will need to install the devel branch from the source repo:
+Starting with 0.3, this library provides out-of-box integration with Snap.Auth.
+
+
+
+### Generics Support
+
+Snap.Extension.DB.MongoDB.Generics module provides generics support to
+facilitate conversion of your data structures to and from Document types.
+
+
+#### Example Generics Usage
+
+
+ import Snap.Extension.DB.MongoDB.Generics
+
+ data Product = Product
+ { proId :: RecKey
+ , proName :: ByteString
+ , proCode :: Maybe ByteString
+ , proAddFields :: Map ByteString ByteString
+ , proOptField :: Optional ByteString
+ } deriving (Eq, Show)
+
+ $(deriveAll ''Product "PFProduct")
+ type instance PF Product = PFProduct
+
+ someP = Product (RecKey Nothing)
+ ("Balta")
+ (Just "101")
+ (Map.singleton "Woohoo" "Yeehaa")
+ (Optional Nothing)
+
+ someDocV1 = toDoc someP
+
+ someDocV2 = do
+ oid <- genObjectId
+ let p = someP { proId = RecKey (Just oid) }
+ return $ toDoc p
+
+
+ sampleDoc =
+ [ u "proId" =: (Nothing :: Maybe ByteString)
+ , u "proName" =: ("Some product" :: ByteString)
+ , u "proCode" =: Just ("Whatever123" :: ByteString)
+ , u "proAddFields" =: (Map.fromList [] :: Map ByteString ByteString)
+ , u "_cons" =: ("Product" :: ByteString)
+ , u "proOptField" =: (123 :: Int)
+ ]
+
+ somePV1 :: Maybe Product
+ somePV1 = fromDoc sampleDoc
+
+ somePV2 :: IO (Maybe Product)
+ somePV2 = do
+ oid <- genObjectId
+ let s = ("_id" =: oid) : sampleDoc
+ return $ fromDoc s
- https://github.com/snapframework/snap-auth/tree/devel
@@ -1,5 +1,5 @@
Name: snap-extension-mongodb
-Version: 0.3.1.0
+Version: 0.3.2.0
Synopsis: MongoDB extension for Snap Framework
Homepage: https://github.com/ozataman/snap-extension-mongodb
License: BSD3
@@ -17,6 +17,11 @@ Library
Exposed-modules:
Snap.Extension.DB.MongoDB
+ , Snap.Extension.DB.MongoDB.Generics
+
+ Other-modules:
+ Snap.Extension.DB.MongoDB.Instances
+ , Snap.Extension.DB.MongoDB.Utils
Build-depends:
base >= 4 && < 5
@@ -26,6 +31,7 @@ Library
, containers >= 0.3
, mongoDB == 0.9
, mtl >= 2 && < 3
+ , regular >= 0.3.2
, safe
, snap >= 0.4 && < 0.5
, snap-core >= 0.4 && < 0.5
@@ -39,6 +39,8 @@ module Snap.Extension.DB.MongoDB
, docToAuthUser
, authUserToDoc
+ , module Snap.Extension.DB.MongoDB.Instances
+
-- * MongoDB Library
-- | Exported for your convenience.
, module Database.MongoDB
@@ -62,16 +64,19 @@ import Data.Map (Map)
import Data.Word (Word8)
import Data.Time
-import Numeric (showHex, readHex)
-import Safe
-
import Database.MongoDB
import Database.MongoDB as DB
+import Numeric (showHex, readHex)
+import Safe
+
import Snap.Types
import Snap.Auth
import Snap.Extension
+import Snap.Extension.DB.MongoDB.Instances
+import Snap.Extension.DB.MongoDB.Utils
+
-- $monadauth
-- This package gives you free MonadAuthUser instances of your application
@@ -98,49 +103,6 @@ class MonadSnap m => MonadMongoDB m where
r <- withDB run
either (error . show) return r
-
-------------------------------------------------------------------------------
--- | Get strict 'ByteString' to work directly with BSON auto-casting
-instance Val B8.ByteString where
- val = val . B8.unpack
- cast' x = fmap B8.pack . cast' $ x
-
-
-------------------------------------------------------------------------------
--- | Get strict 'Text' to work directly with BSON auto-casting
-instance Val T.Text where
- val = val . T.unpack
- cast' x = fmap T.pack . cast' $ x
-
-
-------------------------------------------------------------------------------
--- | Get [Octet] to work directly with BSON auto-casting
-instance Val [Word8] where
- val = val . fmap w2c
- cast' x = fmap (fmap c2w) . cast' $ x
-
-
-------------------------------------------------------------------------------
--- | Make Map UString b an instance of Val for easy conversion of values
-instance (Val b) => Val (Map UString b) where
- val m = val doc
- where f (k,v) = k =: v
- doc = map f $ Map.toList m
- cast' (Doc x) = Map.fromList <$> mapM separate x
- where separate ((:=) k v) = (,) <$> (return k) <*> (cast' v)
- cast' _ = Nothing
-
-
-------------------------------------------------------------------------------
--- | Make Map ByteString b an instance of Val for easy conversion of values
-instance (Val b) => Val (Map ByteString b) where
- val = val . Map.fromList . map convert . Map.toList
- where convert (k,v) = (bs2cs k, v)
- cast' d@(Doc _) = fmap (Map.fromList . map convert . Map.toList) csiCast
- where convert ((CSI.CS k), v) = (k, v)
- csiCast :: (Val c) => Maybe (Map UString c)
- csiCast = cast' d
- cast' _ = Nothing
------------------------------------------------------------------------------
@@ -195,14 +157,10 @@ instance HasMongoDBState s => MonadMongoDB (SnapExtend s) where
(MongoDBState pool db) <- asks getMongoDBState
liftIO . access safe Master pool $ use db run
-
------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Convenience Functions
------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-- | Add timestamps to any document.
@@ -212,52 +170,12 @@ addTimeStamps d = do
let tsc = ["created_at" =: t]
let tsu = ["updated_at" =: t]
return $ tsu `DB.merge` d `DB.merge` tsc
-
-
-------------------------------------------------------------------------------
--- | Convert 'ObjectId' into 'ByteString'
-objid2bs :: ObjectId -> ByteString
-objid2bs (Oid a b) = B8.pack . showHex a . showChar '-' . showHex b $ ""
-
-
-------------------------------------------------------------------------------
--- | Convert 'ByteString' into 'ObjectId'
-bs2objid :: ByteString -> ObjectId
-bs2objid bs = Oid a b
- where (a',b') = break (== '-') . B8.unpack $ bs
- a = fst . head . readHex $ a'
- b = fst . head . readHex $ drop 1 b'
-
-
-bs2cs :: ByteString -> UString
-bs2cs = CSI.CS
-
-
-------------------------------------------------------------------------------
--- | If the 'Document' has an 'ObjectId' in the given field, return it as
--- 'ByteString'
-getObjId :: UString -> Document -> Maybe ByteString
-getObjId v d = Database.MongoDB.lookup v d >>= fmap objid2bs
-
-
--- | Easy lookup from Snap's 'Params'
-lp :: ByteString -> Params -> Maybe ByteString
-lp n m = Map.lookup n m >>= headMay
-
-
+
------------------------------------------------------------------------------
-- Snap Auth Interface
------------------------------------------------------------------------------
-
-------------------------------------------------------------------------------
--- | Make conversion to-from UserId a bit easier
-instance Val UserId where
- val (UserId bs) = val $ bs2objid bs
- cast' x = fmap UserId . fmap objid2bs . cast' $ x
-
-
------------------------------------------------------------------------------
-- | Turn a page from the database into 'AuthUser'
docToAuthUser :: Document -> Maybe AuthUser
Oops, something went wrong.

0 comments on commit c499c6b

Please sign in to comment.