Commits

Anonymous committed 17680f8 Merge

Merge branch 'release/pre-alpha'

Comments (0)

Files changed (9)

+Copyright (c)2011, Kamil Ciemniewski
+
+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 Kamil Ciemniewski 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.
+Snap Framework support for MongoDB as Snaplet
+
+Depends on Snap 0.7.* and <others>
+
+Based on work of Ozgun Ataman
+His Snap Extension for Snap < 0.6.* is here:
+https://github.com/ozataman/snap-extension-mongodb
+
+Code intended for review and refactor.
+import Distribution.Simple
+main = defaultMain

snaplet-mongoDB.cabal

+-- snaplet-mongoDB.cabal auto-generated by cabal init. For additional
+-- options, see
+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
+-- The name of the package.
+Name:                snaplet-mongoDB
+
+-- The package version. See the Haskell package versioning policy
+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
+-- standards guiding when and how versions should be incremented.
+Version:             0.1
+
+-- A short (one-line) description of the package.
+Synopsis:            Snap Framework MongoDB support as Snaplet
+
+-- A longer description of the package.
+-- Description:         
+
+-- The license under which the package is released.
+License:             BSD3
+
+-- The file containing the license text.
+License-file:        LICENSE
+
+-- The package author(s).
+Author:              Kamil Ciemniewski
+
+-- An email address to which users can send suggestions, bug reports,
+-- and patches.
+Maintainer:          ciemniewski.kamil@gmail.com
+
+-- A copyright notice.
+-- Copyright:           
+
+Category:            Web
+
+Build-type:          Simple
+
+-- Extra files to be distributed with the package, such as examples or
+-- a README.
+-- Extra-source-files:  
+
+-- Constraint on the version of Cabal needed to build this package.
+Cabal-version:       >=1.2
+
+
+Library
+  hs-source-dirs: src
+
+  Exposed-modules:
+      Snap.Snaplet.MongoDB
+    , Snap.Snaplet.MongoDB.Generics
+
+  Other-modules:
+      Snap.Snaplet.MongoDB.Instances
+    , Snap.Snaplet.MongoDB.Utils
+  
+  -- Packages needed in order to build this package.
+  Build-depends:
+    base >= 4 && < 5,
+    bytestring >= 0.9.1 && < 0.10,
+    bson == 0.1.6,
+    compact-string-fix == 0.3.2,
+    containers == 0.4.0.0,
+    mongoDB == 1.1.1,
+    mtl >= 2 && < 3,
+    regular >= 0.3.2,
+    safe,
+    snap == 0.7.*,
+    snap-core == 0.7.*,
+    text >= 0.11 && < 0.12,
+    time >= 1.1 && < 1.5
+  
+  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
+  -- Build-tools:    
+  
+  extensions: 
+      OverloadedStrings
+    , FlexibleInstances
+    , TypeSynonymInstances
+    , MultiParamTypeClasses     
+  

src/Snap/Snaplet/MongoDB.hs

+module Snap.Snaplet.MongoDB
+  ( 
+    -- * MongoDB Functionality Inside Snap Monad 
+    MonadMongoDB(..)
+
+    -- * Implementation
+    
+    -- ** Keeping MongoDB State
+  , MongoDBSnaplet(..)
+  , HasMongoDBState(..)
+
+    -- ** Initializing Your Applications
+  , mongoDBInit
+
+
+    -- * Utility Functions
+  , getObjId
+  , bs2objid
+  , bs2objid'
+  , objid2bs
+  , lp
+
+  --  -- * Snap.Auth Interface
+  --  -- $monadauth
+  --, docToAuthUser
+  --, authUserToDoc
+
+  , module Snap.Snaplet.MongoDB.Instances
+
+    -- * MongoDB Library 
+    -- | Exported for your convenience.
+  , module Database.MongoDB
+  ) where
+
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.Trans
+import           Control.Monad.Reader
+import           Control.Monad.Error
+
+import           Data.ByteString.Internal (c2w, w2c)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import           Data.ByteString (ByteString)
+import qualified Data.Text as T
+import qualified Data.CompactString.Internal as CSI
+import qualified Data.CompactString.UTF8 as CS
+import           Data.UString (u)
+import qualified Data.Map as Map
+import           Data.Map (Map)
+import           Data.Word (Word8)
+import           Data.Time
+
+import           Database.MongoDB
+import           Database.MongoDB as DB
+import           Database.MongoDB.Query (Database)
+
+import           Numeric (showHex, readHex)
+import           Safe
+
+import           Snap.Core
+
+import           Snap.Snaplet.MongoDB.Instances
+import           Snap.Snaplet.MongoDB.Utils
+import           Snap.Snaplet.MongoDB.Generics (RecKey)
+
+import           System.IO.Pool
+import           Snap.Snaplet
+
+
+-- $monadauth
+-- This package gives you free MonadAuthUser instances of your application
+-- monad. Once your application becomes MonadMongoDB, if it is also MonadAuth,
+-- it will automatically become MonadAuthUser.
+--
+-- This means you can immediately start using authentication functionality
+-- without worrying about schema, fields, etc. This library will take care of
+-- that for you.
+
+------------------------------------------------------------------------------
+-- | The 'MonadMongoDB' class. Minimal complete definition:
+class MonadIO m => MonadMongoDB m where
+
+  ----------------------------------------------------------------------------
+  -- | Run given MongoDB action against the database
+  withDB       :: Action IO a -> m (Either Failure a)
+  withDBUnsafe :: Action IO a -> m (Either Failure a)
+
+
+
+  ----------------------------------------------------------------------------
+  -- | Same as 'withDB' but calls 'error' if there is an exception
+  withDB' :: Action IO a -> m a
+  withDB' run = do
+    r <- withDB run 
+    either (error . show) return r
+
+            
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+-- Implementation
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+
+---- | MongoDB State
+--data MongoDBState = MongoDBState
+--    { connPool :: Pool IOError Pipe
+--    , appDatabase :: Database
+--    }
+
+
+data MongoDBSnaplet = MongoDBSnaplet {
+  connPoll :: Pool IOError Pipe,
+  appDatabase :: Database
+}
+
+------------------------------------------------------------------------------
+-- |
+class HasMongoDBState s where
+    getMongoDBState :: Handler s s MongoDBSnaplet
+    setMongoDBState :: MongoDBSnaplet -> Handler s s ()
+
+    --modifyMongoDBState :: (MongoDBSnaplet -> MongoDBSnaplet) -> s -> s
+    --modifyMongoDBState s = setMongoDBState s getMongoDBState
+
+
+------------------------------------------------------------------------------
+---- |
+--mongoDBInitializer :: Host
+--                   -> Int
+--                   -> UString
+--                   -> Initializer MongoDBState
+--mongoDBInitializer h n db = do
+--  mongoState <- liftIO $ do
+--    pool <- newPool (factoryForHost h) n
+--    return $ MongoDBState pool (db)
+--  mkInitializer mongoState
+--  where
+--    factoryForHost :: Host -> Factory IOError Pipe
+--    factoryForHost host = Factory (newRes h) (killRes) (isResExpired)
+    
+--    newRes :: Host -> ErrorT IOError IO Pipe
+--    newRes = connect
+    
+--    killRes :: Pipe -> IO ()
+--    killRes = close
+    
+--    isResExpired :: Pipe -> IO Bool
+--    isResExpired = isClosed
+
+mongoDBInit :: Host -> Int -> UString -> SnapletInit b MongoDBSnaplet
+mongoDBInit h n db =
+  makeSnaplet "mongoDB" "MongoDB abstraction" Nothing $ do
+    pool <- liftIO $ newPool (factoryForHost h) n
+    return $ MongoDBSnaplet pool (db)
+  where
+    factoryForHost :: Host -> Factory IOError Pipe
+    factoryForHost host = Factory (newRes h) (killRes) (isResExpired)
+    
+    newRes :: Host -> ErrorT IOError IO Pipe
+    newRes = connect
+    
+    killRes :: Pipe -> IO ()
+    killRes = close
+    
+    isResExpired :: Pipe -> IO Bool
+    isResExpired = isClosed
+
+------------------------------------------------------------------------------
+-- |
+--instance InitializerState MongoDBState where
+--  extensionId = const "MongoDB/MongoDB"
+--  mkCleanup s = killAll $ connPool s
+--  mkReload = const $ return ()
+
+
+------------------------------------------------------------------------------
+-- |
+instance HasMongoDBState s => MonadMongoDB (Handler s s) where
+  withDB run = do
+    (MongoDBSnaplet pool db) <- getMongoDBState
+    epipe <- liftIO $ runErrorT $ aResource pool
+    case epipe of
+      Left err -> return $ Left $ ConnectionFailure err
+      Right pipe -> do
+		liftIO (access pipe master db run)
+
+  withDBUnsafe run = do
+    (MongoDBSnaplet pool db) <- getMongoDBState
+    epipe <- liftIO $ runErrorT $ aResource pool
+    case epipe of
+      Left err -> return $ Left $ ConnectionFailure err
+      Right pipe -> do
+		liftIO (access pipe UnconfirmedWrites db run)
+
+
+------------------------------------------------------------------------------
+-- Convenience Functions
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- | Add timestamps to any document.
+addTimeStamps :: (MonadMongoDB m) => Document -> m Document
+addTimeStamps d = do
+  t <- liftIO getCurrentTime
+  let tsc = ["created_at" =: t]
+  let tsu = ["updated_at" =: t]
+  return $ tsu `DB.merge` d `DB.merge` tsc
+ 
+
+------------------------------------------------------------------------------
+-- Snap Auth Interface
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- | Turn a page from the database into 'AuthUser'
+--docToAuthUser :: Document -> Maybe AuthUser
+--docToAuthUser v = do
+--  uid <- DB.lookup "_id" v
+--  pass <- DB.lookup "password" v
+--  salt <- DB.lookup "salt" v
+--  return emptyAuthUser
+--            { userId = Just uid 
+--            , userEmail = DB.lookup "email" v
+--            , userPassword = Just $ Encrypted pass 
+--            , userSalt = Just salt
+--            , userActivatedAt = DB.lookup "activated_at" v
+--            , userSuspendedAt = DB.lookup "suspended_at" v
+--            , userPersistenceToken = DB.lookup "persistence_token" v
+--            , userCreatedAt = DB.lookup "created_at" v
+--            , userUpdatedAt = DB.lookup "updated_at" v
+--            , userCurrentLoginAt = DB.lookup "current_login_at" v
+--            , userLastLoginAt = DB.lookup "last_login_at" v
+--            , userCurrentLoginIp = DB.lookup "current_login_ip" v
+--            , userLastLoginIp = DB.lookup "last_login_ip" v
+--            , userLoginCount = maybe 0 id $ DB.lookup "login_count" v
+--            , userFailedLoginCount = maybe 0 id $ DB.lookup "failed_login_count" v
+--            }
+
+
+------------------------------------------------------------------------------
+-- | Turn an 'AuthUser' into a 'Document' ready to be commited to DB.
+--authUserToDoc :: AuthUser -> Document
+--authUserToDoc usr = fields'
+--  where
+--    fields' = foldr step [] fields
+--    step x acc = maybe acc (: acc) x
+--    decidePass (Encrypted x) = Just ("password" =: x)
+--    decidePass _ = error "Can't save user without a proper password set"
+--    fields = 
+--      [ userId usr >>= return . ("_id" =:)    -- only if present
+--      , userCreatedAt usr >>= return . ("created_at" =:)  -- only if present
+--      , Just $ ("email" =: userEmail usr)
+--      , userPassword usr >>= decidePass
+--      , Just $ ("salt" =: userSalt usr)
+--      , Just $ ("activated_at" =: userActivatedAt usr)
+--      , Just $ ("suspended_at" =: userSuspendedAt usr)
+--      , Just $ ("persistence_token" =: userPersistenceToken usr)
+--      , Just $ ("current_login_at" =: userCurrentLoginAt usr)
+--      , Just $ ("last_login_at" =: userLastLoginAt usr)
+--      , Just $ ("current_login_ip" =: userCurrentLoginIp usr)
+--      , Just $ ("last_login_ip" =: userLastLoginIp usr)
+--      , Just $ ("login_count" =: userLoginCount usr)
+--      , Just $ ("failed_login_count" =: userFailedLoginCount usr)
+--      ]
+
+
+--instance (MonadAuth m, MonadMongoDB m) => MonadAuthUser m Document where
+
+--  getUserInternal uid = do
+--    t' <- fmap u authUserTable
+--    r <- withDB' $ findOne (select ["_id" =: uid] t')
+--    return $ do
+--      d <- r 
+--      (,) <$> docToAuthUser d <*> r
+
+
+--  getUserByRememberToken t = do
+--    t' <- fmap u authUserTable
+--    r <- withDB' $ findOne (select ["persistence_token" =: t] t')
+--    return $ do
+--      d <- r
+--      (,) <$> docToAuthUser d <*> r
+
+
+--  getUserExternal (EUId ps) = do
+--    lookup_keys <- authAuthenticationKeys
+--    t' <- fmap u authUserTable
+--    r <- withDB' $ findOne (select (buildConditions lookup_keys) t')
+--    return $ do
+--      d <- r 
+--      (,) <$> docToAuthUser d <*> r
+--    where 
+--      buildConditions ks = map cond ks
+--        where cond k = bs2cs k =: (fmap bs2cs $ lp k ps)
+
+
+--  saveAuthUser (user, d0) = do
+--    t' <- fmap u authUserTable
+--    user' <- updateUser
+--    d <- addTimeStamps $ authUserToDoc user'
+--    let d' = d `DB.merge` d0
+--    case userId user of
+--      Just _ -> do    -- Existing user
+--        withDB' $ save t' d' >> return Nothing
+--        return . Just $ user'
+--      Nothing -> do   -- New user
+--        uid <- withDB' $ insert t' d' 
+--        return . Just $ user' { userId = cast' uid }
+--    where
+--      updateUser = case userPassword user of
+--        Just (ClearText x) -> updateUserPass x
+--        Nothing -> error "Can't save user without any form of password"
+--        _ -> return user
+--      updateUserPass x = do
+--        (newsalt, newpass) <- mkAuthCredentials x
+--        return $ user { userPassword = Just (Encrypted newpass)
+--                      , userSalt = Just newsalt }

src/Snap/Snaplet/MongoDB/Generics.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Snap.Snaplet.MongoDB.Generics 
+
+(
+  -- * Conversion Functions
+  toDoc
+, fromDoc
+
+  -- * Utilities
+, fromDocList
+, toDocList
+--
+, insertADT
+, insertADT_
+, insertManyADT
+, insertManyADT_
+--
+, saveADT
+, replaceADT
+, repsertADT
+--
+, restADT
+, nextNADT
+, nextADT
+, groupADT
+
+  -- * Useful Types
+, RecKey(..)
+, Optional(..)
+
+  -- * Needed typeclasses for Generics support
+, ToDoc(..)
+, FromDoc(..)
+
+  -- * Regular generics library exported for convenience
+, module Generics.Regular
+
+)
+
+where
+
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+
+import Database.MongoDB hiding (Selector)
+import Control.Monad.MVar
+import Data.Bson
+import Data.Typeable
+import Data.Monoid hiding (Product)
+import qualified Data.Bson as D
+import Data.UString (u)
+import qualified Data.Typeable as T
+import Data.ByteString.Internal (c2w, w2c)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import Data.Map (Map)
+import qualified Data.CompactString.Internal as CSI
+import qualified Data.Map as Map
+import           Data.Word (Word8)
+
+import Generics.Regular
+
+import Snap.Snaplet.MongoDB.Instances
+import Snap.Snaplet.MongoDB.Utils
+
+
+------------------------------------------------------------------------------
+-- | Use 'RecKey' type to map the _id attribute to your ADT.
+--
+-- This field will get treated differently. If it is there, it will be used. If
+-- you put a 'Nothing', it will be ommitted so that MongoDB assigns one
+-- automatically. Helpful when a record is being created.
+newtype RecKey = RecKey { unRK :: Maybe ObjectId }
+  deriving (Eq, Show, Typeable)
+
+
+------------------------------------------------------------------------------
+-- | Datatype to encode optional arguments.
+--
+-- Sometimes, we don't want Document to data-type conversion to fail just
+-- because some field is not present in the database. Define such fields as
+-- 'Optional' and they will get special treatment in cases where they are
+-- missing entirely.
+newtype Optional a = Optional { unOpt :: Maybe a }
+  deriving (Eq, Show, Monad, Functor, Applicative, MonadPlus, Monoid, Typeable)
+
+
+------------------------------------------------------------------------------
+-- | 'Val' instance for 'Optional'
+instance (Val a) => Val (Optional a) where
+    val (Optional x) = val x
+    cast' x = fmap Optional $ cast' x 
+
+------------------------------------------------------------------------------
+-- Generics typeclass to convert ADTs to 'Document'
+--
+class ToDoc f where
+  toDocPF :: f a -> Document
+
+instance ToDoc U where
+  toDocPF _ = []
+
+instance ToDoc I where
+  toDocPF (I r) = []
+
+instance (Regular a, ToDoc (PF a)) => ToDoc (K a) where
+  toDocPF (K r) = toDoc r
+  toDocPF _ = []
+
+instance (Selector s, Val r) => ToDoc (S s (K r)) where
+  toDocPF s@(S (K x)) = [u (selName s) =: x]
+  toDocPF _ = []
+
+instance (Selector s) => ToDoc (S s (K RecKey)) where
+  toDocPF s@(S (K (RecKey (Just x)))) = [u "_id" =: x]
+  toDocPF _ = []
+
+instance (ToDoc f, ToDoc g) => ToDoc (f :+: g) where
+  toDocPF (L x) = toDocPF x
+  toDocPF (R x) = toDocPF x
+
+instance (ToDoc f, ToDoc g) => ToDoc (f :*: g) where
+  toDocPF (x :*: y) = toDocPF x ++ toDocPF y
+
+instance (ToDoc f, Constructor c) => ToDoc (C c f) where
+  toDocPF c@(C x) = toDocPF x ++ ["_cons" =: (u . conName) c]
+
+
+------------------------------------------------------------------------------
+-- | Convert arbitrary data type into 'Document'
+toDoc :: (Regular a, ToDoc (PF a)) => a -> Document
+toDoc x = toDocPF . from $ x
+
+
+------------------------------------------------------------------------------
+-- | A class that implements getting all the record labels in a list
+--
+class GetSelectors f where
+  selsPF :: f r -> [String]
+
+instance (Selector s, GetSelectors f) => GetSelectors (S s f) where
+  selsPF s@(S x) = [selName s] ++ selsPF x
+
+instance (GetSelectors f, GetSelectors g) => GetSelectors (f :+: g) where
+  selsPF (L x) = selsPF x
+  selsPF (R x) = selsPF x
+
+instance (GetSelectors f, GetSelectors g) => GetSelectors (f :*: g) where
+  selsPF (x :*: y) = selsPF x ++ selsPF y
+
+instance (GetSelectors f) => GetSelectors (C c f) where
+  selsPF (C x) = selsPF x
+
+
+------------------------------------------------------------------------------
+-- | A class that implements conversion of 'Document' objects into arbitrary
+-- algebraic types.
+--
+class FromDoc f where
+  fromDocPF :: Document -> Maybe (f a)
+
+
+instance (Regular a, FromDoc (PF a)) => FromDoc (K a) where
+  fromDocPF d = fromDoc d >>= return . K
+
+
+instance (Val r, Selector s) => FromDoc (S s (K r)) where
+  fromDocPF d = D.lookup k d >>= return . S . K
+    where
+      k = u . selName $ (undefined :: S s f a)
+
+
+instance (Selector s) => FromDoc (S s (K RecKey)) where
+  fromDocPF d = 
+    case D.lookup "_id" d of
+      Just x -> return . S . K . RecKey $ Just x
+      Nothing -> return . S . K . RecKey $ Nothing
+
+
+instance (Val r, Selector s) => FromDoc (S s (K (Optional r))) where
+  fromDocPF d = 
+    case D.lookup k d of
+      Just x -> return . S . K . Optional $ Just x
+      Nothing -> return . S . K . Optional $ Nothing
+    where
+      k = u . selName $ (undefined :: S s f a)
+
+instance (Constructor c, FromDoc f) => FromDoc (C c f) where
+  fromDocPF d = do
+    cnm <- D.lookup "_cons" d
+    case (cnm == conName (undefined :: C c f r)) of
+      True -> fromDocPF d >>= return . C 
+      False -> Nothing
+
+instance (FromDoc f, FromDoc g) => FromDoc (f :+: g) where
+  fromDocPF d = l `mplus` r
+    where
+      l = fromDocPF d >>= return . L
+      r = fromDocPF d >>= return . R
+
+instance (FromDoc f, FromDoc g) => FromDoc (f :*: g) where
+  fromDocPF d = do
+    x <- fromDocPF d
+    y <- fromDocPF d
+    return $ x :*: y
+
+------------------------------------------------------------------------------
+-- | Convert a 'Document' into arbitrary data type.
+fromDoc :: (Regular a, FromDoc (PF a)) => Document -> Maybe a
+fromDoc d = fromDocPF d >>= return . to
+
+------------------------------------------------------------------------------
+-- | Utilities -- functions for your convenience
+
+fromDocList :: (Regular a, FromDoc (PF a)) => [Document] -> [a]
+fromDocList = catMaybes . map fromDoc
+
+toDocList :: (Regular a, ToDoc (PF a)) => [a] -> [Document]
+toDocList = map toDoc
+
+-- Insert
+
+insertADT :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Collection -> a -> Action m Value
+insertADT c = insert c . toDoc
+
+insertADT_ :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Collection -> a -> Action m ()
+insertADT_ c adt = insertADT c adt >> return ()
+
+insertManyADT :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Collection -> [a] -> Action m [Value]
+insertManyADT c = insertMany c . map toDoc
+
+insertManyADT_ :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Collection -> [a] -> Action m ()
+insertManyADT_ c adts = insertManyADT c adts >> return ()
+
+-- Update
+
+saveADT :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Collection -> a -> Action m ()
+saveADT c adt = save c $ toDoc adt
+
+replaceADT :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Selection -> a -> Action m () -- perhaps replaceWithADT would be better?
+replaceADT s adt = replace s $ toDoc adt
+
+repsertADT :: (Regular a, ToDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Selection -> a -> Action m () -- perhaps repsertWithADT would be better?
+repsertADT s adt = repsert s $ toDoc adt
+
+--
+
+restADT :: (Regular a, FromDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Cursor -> Action m [a]
+restADT c = rest c >>= return . fromDocList
+
+nextNADT :: (Regular a, FromDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Int -> Cursor -> Action m [a]
+nextNADT n c = nextN n c >>= return . fromDocList
+
+nextADT :: (Regular a, FromDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Cursor -> Action m (Maybe a)
+nextADT c = next c >>= return . (maybe Nothing fromDoc)
+
+groupADT :: (Regular a, FromDoc (PF a), MonadControlIO m, Functor m, Applicative m) => Group -> Action m [a]
+groupADT g = group g >>= return . fromDocList
+
+
+------------------------------------------------------------------------------
+-- Testing
+
+
+{-data Acme = ABC ByteString | One Int | Two Double | SomeDoc Document-}
+
+{-$(deriveAll ''Acme "PFAcme")-}
+{-type instance PF Acme = PFAcme-}
+
+{-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-}

src/Snap/Snaplet/MongoDB/Instances.hs

+module Snap.Snaplet.MongoDB.Instances where
+
+
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.Trans
+import           Control.Monad.Reader
+
+import           Data.ByteString.Internal (c2w, w2c)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import           Data.ByteString (ByteString)
+import qualified Data.Text as T
+import qualified Data.CompactString.Internal as CSI
+import qualified Data.CompactString.UTF8 as CS
+import           Data.UString (u)
+import qualified Data.Map as Map
+import           Data.Map (Map)
+import           Data.Word (Word8)
+import           Data.Time
+
+
+import Data.Bson
+
+import           Snap.Snaplet.MongoDB.Utils
+
+
+------------------------------------------------------------------------------
+-- | 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
+
+------------------------------------------------------------------------------
+-- | 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
+
+
+

src/Snap/Snaplet/MongoDB/Utils.hs

+module Snap.Snaplet.MongoDB.Utils where
+
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.Trans
+import           Control.Monad.Reader
+
+import           Data.ByteString.Internal (c2w, w2c)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import           Data.ByteString (ByteString)
+import           Data.Maybe (fromJust)
+import qualified Data.Text as T
+import qualified Data.CompactString.Internal as CSI
+import qualified Data.CompactString.UTF8 as CS
+import           Data.UString (u)
+import qualified Data.Map as Map
+import           Data.Map (Map)
+import           Data.Word (Word8)
+import           Data.Time
+
+import           Database.MongoDB
+import           Database.MongoDB as DB
+
+import           Numeric (showHex, readHex)
+import           Safe
+
+import           Snap.Types
+
+
+------------------------------------------------------------------------------
+-- | Convert 'ObjectId' into 'ByteString'
+objid2bs :: ObjectId -> ByteString
+objid2bs (Oid a b) = B8.pack . showHex a . showChar '-' . showHex b $ ""
+
+
+------------------------------------------------------------------------------
+-- | Convert 'ByteString' into 'ObjectId'
+bs2objid :: ByteString -> Maybe ObjectId
+bs2objid bs = do
+  case B8.split '-' bs of
+    (a':b':_) -> do
+      a <- fmap fst . headMay . readHex . B8.unpack $ a'
+      b <- fmap fst . headMay . readHex . B8.unpack $ b'
+      return $ Oid a b
+    _ -> Nothing
+
+------------------------------------------------------------------------------
+-- | Like 'bs2objid', but may blow with an error if the 'ByteString' can't be
+-- converted to an 'ObjectId'
+bs2objid' :: ByteString -> ObjectId
+bs2objid' = fromJust . bs2objid
+
+
+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
+