Anonymous avatar Anonymous committed df0ea16

Changed to mt-mongodb

Comments (0)

Files changed (10)

snaplet-mongoDB.cabal

 Library
   hs-source-dirs: src
 
-  Exposed-modules:
-      Snap.Snaplet.MongoDB
-    , Snap.Snaplet.MongoDB.Generics
-
-  Other-modules:
-      Snap.Snaplet.MongoDB.Instances
-    , Snap.Snaplet.MongoDB.Utils
+  library
+  exposed-modules:  Snap.Snaplet.MongoDB
+                  , Snap.Snaplet.MongoDB.Template
   
   -- Packages needed in order to build this package.
   Build-depends:
     snap == 0.7.*,
     snap-core == 0.7.*,
     text >= 0.11 && < 0.12,
-    time >= 1.1 && < 1.5
+    time >= 1.1 && < 1.5,
+    parsec == 3.1.1,
+    haskell-src-exts == 1.11.1,
+    template-haskell
   
   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
   -- Build-tools:    

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
+  , insert
+  , insertMany
+  , insertWith
+  , get
+  , getMany
+  , delete
+  , deleteWhere
+  , select
+  , selectOne
+  , count
+  , save
+  , update
+  , updateWhere
+   
+  , filters
+  , updates
+   
+  , offset
+  , limit
+  , orderAsc
+  , orderDesc
+   
+  , module Snap.Snaplet.MongoDB.FilterOps
+  , module Snap.Snaplet.MongoDB.MongoEntity
+  , module Snap.Snaplet.MongoDB.MongoValue
+  , module Snap.Snaplet.MongoDB.Template
+  , module Snap.Snaplet.MongoDB.Parse
+  , MongoDB.Action
+  , MongoDB.MonadIO'
   ) 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
 
+import           Prelude hiding (lookup, or)
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.MVar
+import           Control.Monad.Error
+import           Data.Bson ((=:))
+import qualified Data.Bson as BSON
+import qualified Data.UString as US
+import           Data.Maybe (catMaybes)
+import           Snap.Snaplet.MongoDB.FilterOps
+import           Snap.Snaplet.MongoDB.MongoEntity
+import           Snap.Snaplet.MongoDB.MongoValue
+import           Snap.Snaplet.MongoDB.Template
+import           Snap.Snaplet.MongoDB.Parse
+import qualified Database.MongoDB as MongoDB
+import qualified Database.MongoDB.Internal.Util as MongoDB
+import           Database.MongoDB.Query (Action, Failure(..), Database, access, master, AccessMode(..))
+import qualified Database.MongoDB.Connection as MongoDB
+import qualified System.IO.Pool as MPool
 
--- $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:
     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,
+  connPoll :: MPool.Pool IOError MongoDB.Pipe,
   appDatabase :: Database
 }
 
     --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 :: MongoDB.Host -> Int -> US.UString -> SnapletInit b MongoDBSnaplet
 mongoDBInit h n db =
   makeSnaplet "mongoDB" "MongoDB abstraction" Nothing $ do
-    pool <- liftIO $ newPool (factoryForHost h) n
+    pool <- liftIO $ MPool.newPool (factoryForHost h) n
     return $ MongoDBSnaplet pool (db)
   where
-    factoryForHost :: Host -> Factory IOError Pipe
-    factoryForHost host = Factory (newRes h) (killRes) (isResExpired)
+    factoryForHost :: MongoDB.Host -> MPool.Factory IOError MongoDB.Pipe
+    factoryForHost host = MPool.Factory (newRes h) (killRes) (isResExpired)
     
-    newRes :: Host -> ErrorT IOError IO Pipe
-    newRes = connect
+    newRes :: MongoDB.Host -> ErrorT IOError IO MongoDB.Pipe
+    newRes = MongoDB.connect
     
-    killRes :: Pipe -> IO ()
-    killRes = close
+    killRes :: MongoDB.Pipe -> IO ()
+    killRes = MongoDB.close
     
-    isResExpired :: Pipe -> IO Bool
-    isResExpired = isClosed
-
-------------------------------------------------------------------------------
--- |
---instance InitializerState MongoDBState where
---  extensionId = const "MongoDB/MongoDB"
---  mkCleanup s = killAll $ connPool s
---  mkReload = const $ return ()
-
+    isResExpired :: MongoDB.Pipe -> IO Bool
+    isResExpired = MongoDB.isClosed
 
 ------------------------------------------------------------------------------
 -- |
 instance HasMongoDBState s => MonadMongoDB (Handler s s) where
   withDB run = do
     (MongoDBSnaplet pool db) <- getMongoDBState
-    epipe <- liftIO $ runErrorT $ aResource pool
+    epipe <- liftIO $ runErrorT $ MPool.aResource pool
     case epipe of
       Left err -> return $ Left $ ConnectionFailure err
       Right pipe -> do
 
   withDBUnsafe run = do
     (MongoDBSnaplet pool db) <- getMongoDBState
-    epipe <- liftIO $ runErrorT $ aResource pool
+    epipe <- liftIO $ runErrorT $ MPool.aResource pool
     case epipe of
       Left err -> return $ Left $ ConnectionFailure err
       Right pipe -> do
 		liftIO (access pipe UnconfirmedWrites db run)
 
 
-------------------------------------------------------------------------------
--- Convenience Functions
-------------------------------------------------------------------------------
+-- | Given a type in the type class 'MongoEntity', insert this as a new document in the database. The function will
+-- yield the unique key for the new document.
+insert :: (MongoDB.MonadIO' m, MongoEntity a) => a -> MongoDB.Action m (Key a)
+insert obj = do
+  (BSON.ObjId objId) <- MongoDB.insert (collectionName obj) (fromDocument $ encodeDocument obj)
+  pure $! toKey objId
+
+
+-- | Similar to 'insert', this function inserts multiple documents into the databsae, yielding a unique key for each.
+insertMany :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => [a] -> MongoDB.Action m [Key a]
+insertMany []   = pure []
+insertMany objs = do
+  ids <- MongoDB.insertMany (collectionName $ head objs) (map (fromDocument . encodeDocument) objs)
+  forM ids $ \x -> case x of
+                    BSON.ObjId objId -> pure $! toKey objId
+                    _                -> throwError $ MongoDB.QueryFailure 1000 "Expected object ID as result of 'insertMany'"
+
+-- | Similar to 'insert', but allows you to specify the ID with which the object is to be created.
+insertWith :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> a -> MongoDB.Action m (Key a)
+insertWith key obj = do
+  (BSON.ObjId objId) <- MongoDB.insert (collectionName obj) (("_id" =: fromKey key) : (fromDocument $ encodeDocument obj))
+  pure $! toKey objId
+
+
+-- | Given a unique key for a 'MongoEntity', yield that entity. If no document with the specified ID was found, the
+-- function will yield @Nothing@.
+get :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> MongoDB.Action m (Maybe a)
+get key = do
+  let collection = collectionName (dummyFromKey key)
+  result <- MongoDB.findOne (MongoDB.select ["_id" =: fromKey key] collection)
+  case result of
+    Just document -> do
+      eObj <- runErrorT (decodeDocument $ toDocument document)
+      case eObj of
+        Left message -> throwError $ MongoDB.QueryFailure 1001 message
+        Right    obj -> pure (Just obj)
+    Nothing ->
+      pure Nothing
+
+-- | The application of 'get' to many keys.
+getMany :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => [Key a] -> MongoDB.Action m [Maybe a]
+getMany = mapM get
+
+-- | Delete the document with the specified key.
+delete :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> MongoDB.Action m ()
+delete key = do
+  let collection = collectionName (dummyFromKey key)
+  MongoDB.deleteOne (MongoDB.select ["_id" =: fromKey key] collection)
+
+deleteWhere :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> MongoDB.Action m ()
+deleteWhere doc = do
+  MongoDB.delete (MongoDB.select (fromDocument doc) (collectionName (dummyFromDocument doc)))
+
+count :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> MongoDB.Action m Int
+count doc = do
+  MongoDB.count (MongoDB.select (fromDocument doc) (collectionName (dummyFromDocument doc)))
+
+type SelectorOption = MongoDB.Query -> MongoDB.Query
+
+offset :: Int -> SelectorOption
+offset n q = q { MongoDB.skip = fromIntegral n }
+
+limit :: Int -> SelectorOption
+limit n q = q { MongoDB.limit = fromIntegral n }
+
+orderAsc :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> SelectorOption
+orderAsc f q = q { MongoDB.sort = (filterFieldName (f undefined) =: (1 :: Int)) : MongoDB.sort q }
+
+orderDesc :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> SelectorOption
+orderDesc f q = q { MongoDB.sort = (filterFieldName (f undefined) =: ((-1) :: Int)) : MongoDB.sort q }
+
+
+-- | Select all matching documents from a collection in the database. This function yields a list of pairs of the unique
+-- key and the 'MongoEntity' for each matching document in the collection.
+--
+-- The query can be made using either the quasi-quoted mongoDB query format:
+--
+-- @select [mongo| { userName: #{name}, userPassword: #{password} |] []@
+--
+-- Or using the filter operations:
+--
+-- @select (filters [UserName `eq` name, UserPassword `eq` password]) []@
+--
+-- /Note/: in the quasi-quotation the names of the fields correspond to the fields stored in the /database/, rather than
+-- the fields of the record structure.
+--
+select :: (Functor m, MonadControlIO m, MongoEntity a) => Document a -> [SelectorOption] -> MongoDB.Action m [(Key a, a)]
+select document options = do
+  cursor  <- MongoDB.find (foldr ($) (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) options)
+  objects <- MongoDB.rest cursor
+  values  <- mapM fetchKeyValue objects
+  return $ catMaybes values
 
-------------------------------------------------------------------------------
--- | 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
- 
+-- | Similar to 'select', only yielding a single result.
+selectOne :: (Functor m, MonadControlIO m, MongoEntity a) => Document a -> [SelectorOption] -> MongoDB.Action m (Maybe (Key a, a))
+selectOne document options = do
+  result <- MongoDB.findOne (foldr ($) (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) options)
+  case result of
+    Just obj -> fetchKeyValue obj
+    Nothing  -> pure Nothing
 
-------------------------------------------------------------------------------
--- 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
---            }
+save :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> a -> MongoDB.Action m ()
+save key obj = do
+  MongoDB.save (collectionName obj) (("_id" := BSON.ObjId (fromKey key)) : (fromDocument $ encodeDocument obj))
 
 
-------------------------------------------------------------------------------
--- | 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 }
+update :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> Document a -> MongoDB.Action m ()
+update key updateDoc = do
+  MongoDB.modify (MongoDB.select [ "_id" =: (fromKey key) ] (collectionName (dummyFromKey key))) (fromDocument updateDoc)
+
+updateWhere :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> Document a -> MongoDB.Action m ()
+updateWhere document updateDoc = do
+  MongoDB.modify (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) (fromDocument updateDoc)
+
+
+filters :: (MongoEntity a) => [FilterOp] -> Document a
+filters = toDocument
+
+updates :: (MongoEntity a) => [UpdateOp] -> Document a
+updates = toDocument
+
+
+fetchKeyValue :: (Functor m, MonadControlIO m, MongoEntity a) => BSON.Document -> MongoDB.Action m (Maybe (Key a, a))
+fetchKeyValue doc = do
+  case BSON.look "_id" doc of
+    Just i ->
+      case i of
+        BSON.ObjId objId -> do
+          eObj <- runErrorT (decodeDocument $ toDocument doc)
+          case eObj of
+            Left message -> throwError $ MongoDB.QueryFailure 1001 message
+            Right    obj -> pure $ Just (toKey objId, obj)
+        _ -> throwError $ MongoDB.QueryFailure 1000 "Expected _id field to be an ObjectId in result of selection"
+    Nothing ->
+      throwError $ MongoDB.QueryFailure 1000 "Expected to find an _id field in result of selection"
+
+
+dummyFromKey :: Key a -> a
+dummyFromKey _ = undefined
+
+dummyFromDocument :: Document a -> a
+dummyFromDocument _ = undefined

src/Snap/Snaplet/MongoDB/FilterOps.hs

+{-# LANGUAGE OverloadedStrings #-}
+-- |
+-- Module      : Snap.Snaplet.MongoDB.FilterOps
+-- Description : Provides the filtering operations.
+-- Copyright   : (C) 2011 Massive Tactical Limited
+-- License     : BSD3
+--
+-- Maintainer  : Blake Rain <blake.rain@massivetactical.com>
+-- Stability   : Provisional
+-- Portability : Portable
+--
+-- Provides the filtering operations.
+--
+
+module Snap.Snaplet.MongoDB.FilterOps
+       ( FilterOp
+         
+       , (==?)
+       , (/=?)
+       , eq, ne, lt, lte, gt, gte
+       , or, ors
+       , isIn, notIn
+               
+       , UpdateOp
+       , (==:)
+       , set
+       , inc, dec
+       , pop, push, pull, pushAll, pullAll
+       , addToSet, addManyToSet
+       ) where
+
+import           Prelude hiding (or)
+import qualified Data.Bson as BSON
+import           Snap.Snaplet.MongoDB.MongoValue
+import           Snap.Snaplet.MongoDB.MongoEntity
+
+
+infix 0 ==?  -- Alias to eq operation
+infix 0 /=?  -- Alias to neq operation
+infix 0 ==:  -- Alias to set operation
+
+type FilterOp = BSON.Field
+
+(==?), (/=?), (==:) :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> FilterOp
+(==?) = eq
+(/=?) = ne
+(==:) = set
+
+stdFilterDef :: (MongoEntity a, MongoValue v) => BSON.Label -> (v -> Filter a) -> v -> FilterOp
+stdFilterDef op f v =
+  filterFieldName (f undefined) := BSON.Doc [op := toValue v]
+
+eq, ne, lt, lte, gt, gte :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> FilterOp
+eq f v = filterFieldName (f undefined) := toValue v
+ne     = stdFilterDef "$ne"
+lt     = stdFilterDef "$lt"
+lte    = stdFilterDef "$lte"
+gt     = stdFilterDef "$gt"
+gte    = stdFilterDef "$gte"
+
+or :: BSON.Field -> BSON.Field -> FilterOp
+or x y = "$or" := BSON.Doc [x, y]
+
+ors :: [BSON.Field] -> BSON.Field
+ors fs = "$or" := BSON.Doc fs
+
+isIn, notIn :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> [v] -> FilterOp
+isIn  f vs = filterFieldName (f undefined) := BSON.Doc [  "$in" := BSON.Array (map toValue vs) ]
+notIn f vs = filterFieldName (f undefined) := BSON.Doc [ "$nin" := BSON.Array (map toValue vs) ]
+
+
+type UpdateOp = BSON.Field
+
+set :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> UpdateOp
+set f v = "$set" := BSON.Doc [ filterFieldName (f v) := toValue v ]
+
+inc, dec :: (MongoEntity a, Num v, MongoValue v) => (v -> Filter a) -> v -> UpdateOp
+inc f v = "$inc" := BSON.Doc [ filterFieldName (f v) := toValue v ]
+dec f v = "$dec" := BSON.Doc [ filterFieldName (f v) := toValue v ]
+
+push, addToSet, pull :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> v -> UpdateOp
+push     f v = "$push" := BSON.Doc [ filterFieldName (f [v]) := toValue v ]
+addToSet f v = "$addToSet" := BSON.Doc [ filterFieldName (f undefined) := toValue v ]
+pull     f v = "$pull" := BSON.Doc [ filterFieldName (f undefined) := toValue v ]
+
+pushAll, pullAll, addManyToSet :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> [v] -> UpdateOp
+pushAll      f v = "$pushAll" := BSON.Doc [ filterFieldName (f undefined) := BSON.Array (map toValue v) ]
+pullAll      f v = "$pullAll" := BSON.Doc [ filterFieldName (f undefined) := BSON.Array (map toValue v) ]
+addManyToSet f v = "$addToSet" := BSON.Doc [ filterFieldName (f undefined) := BSON.Doc [ "$each" := BSON.Array (map toValue v) ] ]
+
+pop :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> UpdateOp
+pop f = "$pop" := BSON.Doc [ filterFieldName (f undefined) := BSON.Int32 1 ]
+
+
+
+-- Local Variables:
+-- mode                  : Haskell
+-- fill-column           : 120
+-- default-justification : left
+-- End:

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/MongoEntity.hs

+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}
+-- |
+-- Module : Snap.Snaplet.MongoDB.MongoEntity
+-- Description : Provides the MongoEntity type class.
+-- Copyright : (C) 2011 Massive Tactical Limited
+-- License : BSD3
+--
+-- Maintainer : Blake Rain <blake.rain@massivetactical.com>
+-- Stability : Provisional
+-- Portability : Portable
+--
+-- Provides the MongoEntity type class.
+--
+
+module Snap.Snaplet.MongoDB.MongoEntity
+       ( MongoEntity (..)
+       ) where
+
+
+import           Control.Applicative
+import           Control.Monad.Error
+import qualified Data.Bson        as BSON
+import           Data.Monoid
+import qualified Database.MongoDB as DB
+import           Snap.Snaplet.MongoDB.MongoValue
+import           Numeric (readHex)
+import           Text.Read
+import qualified Text.ParserCombinators.ReadP as R
+import qualified Text.ParserCombinators.ReadPrec as R (lift, readS_to_Prec)
+
+
+-- | Any type that is an instance of this type class can be stored and retrieved as an object from a MongoDB collection.
+class (Show (Key a), MongoValue (Key a)) => MongoEntity a where
+  data Key a
+  data Filter a
+  data Document a
+  
+  -- | Convert an 'ObjectId' to a 'Key'.
+  toKey               :: ObjectId -> Key a
+  -- | Convert a 'Key' to an 'ObjectId'
+  fromKey             :: Key a -> ObjectId
+  
+  -- | Convert a 'BSON.Document' to a 'Document'.
+  toDocument          :: BSON.Document -> Document a
+  -- | Convert a 'Document' to a 'BSON.Document'.
+  fromDocument        :: Document a -> BSON.Document
+  
+  -- | Yields the name of the collection to which this type belongs.
+  collectionName      :: a -> DB.Collection
+  -- | Yields the name of the corresponding field in a collection for the given filter.
+  filterFieldName     :: Filter a -> BSON.Label
+  
+  -- | Encode an object into a 'BSON.Document' that can be stored in a collection.
+  encodeDocument      :: a -> Document a
+  -- | Decode a 'BSON.Document' into this type; possibly failing.
+  decodeDocument      :: (Applicative m, Monad m) => Document a -> ErrorT String m a
+
+
+instance (MongoEntity a) => MongoValue (Key a) where
+  toValue = BSON.ObjId . fromKey
+  fromValue (BSON.ObjId o) = return $ toKey o
+  fromValue v              = expected "ObjectId" v
+
+instance (MongoEntity a) => MongoValue (Document a) where
+  toValue = toValue . fromDocument
+  fromValue (BSON.Doc doc) = return $ toDocument doc
+  fromValue v              = expected "Document" v
+
+instance (MongoEntity a) => Monoid (Document a) where
+  mempty = toDocument []
+  mappend x y = toDocument (fromDocument x ++ fromDocument y)
+
+instance (MongoEntity a) => Show (Key a) where
+  show = show . fromKey
+
+instance (MongoEntity a) => Read (Key a) where
+  readPrec = do
+    [(x, "")] <- readHex <$> R.lift (R.count 8 R.get)
+    y <- R.readS_to_Prec $ const readHex
+    return (toKey (BSON.Oid x y))
+
+
+
+-- Local Variables:
+-- mode                  : Haskell
+-- fill-column           : 120
+-- default-justification : left
+-- End:

src/Snap/Snaplet/MongoDB/MongoValue.hs

+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE TupleSections, TypeSynonymInstances, RankNTypes, ScopedTypeVariables, IncoherentInstances #-}
+-- |
+-- Module      : Snap.Snaplet.MongoDB.MongoValue
+-- Description : Provides the MongoValue type class and basic instances.
+-- Copyright   : (C) 2011 Massive Tactical Limited
+-- License     : BSD3
+--
+-- Maintainer  : Blake Rain <blake.rain@massivetactical.com>
+-- Stability   : Provisional
+-- Portability : Unknown
+--
+-- Provides the MongoValue type class and some basic instances.
+--
+
+module Snap.Snaplet.MongoDB.MongoValue
+       ( MongoValue (..)
+       , BSON.Value (..)
+--       , BSON.Document (..)
+       , BSON.Field (..)
+       , BSON.ObjectId (..)
+       , nullObjectId
+       , expected
+--       , lookMaybe
+       , lookupThrow
+       ) where
+
+import           Prelude hiding (lookup, or)
+import           Control.Applicative
+import           Control.Monad.Error
+import           Data.Bson (Field ((:=)), ObjectId (..))
+import qualified Data.Bson as BSON
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import           Data.Char
+import qualified Data.CompactString.UTF8 as CS
+import           Data.Int
+import           Data.List (find)
+import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import           Data.Time
+import           Data.Time.Clock.POSIX
+import           Text.Printf
+
+
+
+-- | This type class represents all types which can be marshalled too and from the BSON format.
+class MongoValue a where
+  toValue   :: a -> BSON.Value
+  fromValue :: (Applicative m, Monad m) => BSON.Value -> ErrorT String m a
+
+
+expected :: (Monad m) => String -> BSON.Value -> ErrorT String m a
+expected what was =
+  throwError $ printf "Expected %s; found %s" what (describeType was)
+  where
+    describeType :: BSON.Value -> String
+    describeType (BSON.Float   _) = "Float"
+    describeType (BSON.String  _) = "String"
+    describeType (BSON.Doc     _) = "Document"
+    describeType (BSON.Array   n) = printf "Array (BSON.with %i elements)" (length n)
+    describeType (BSON.Bin     _) = "Binary"
+    describeType (BSON.Fun     _) = "Function"
+    describeType (BSON.Uuid    _) = "UUID"
+    describeType (BSON.Md5     _) = "MD5"
+    describeType (BSON.UserDef _) = "UserDefined"
+    describeType (BSON.ObjId   _) = "ObjectId"
+    describeType (BSON.Bool    _) = "Bool"
+    describeType (BSON.UTC     _) = "UTCTime"
+    describeType (BSON.Null     ) = "null"
+    describeType (BSON.RegEx   _) = "RegEx"
+    describeType (BSON.JavaScr _) = "JavaScript"
+    describeType (BSON.Sym     _) = "Symbol"
+    describeType (BSON.Int32   _) = "Int32"
+    describeType (BSON.Int64   _) = "Int64"
+    describeType (BSON.Stamp   _) = "Stamp"
+    describeType (BSON.MinMax  _) = "MinMax"
+
+
+-- | Represents a null 'ObjectId' (all zeros).
+nullObjectId :: ObjectId
+nullObjectId = Oid 0 0
+
+lookMaybe :: T.Text -> BSON.Document -> Maybe BSON.Value
+lookMaybe name doc =
+  let name' = textToCompactString name in maybe Nothing (Just . BSON.value) $ find ((name' ==) . BSON.label) doc
+
+lookupThrow :: (Applicative m, Monad m, MongoValue a) => T.Text -> BSON.Document -> ErrorT String m a
+lookupThrow name doc =
+  case lookMaybe name doc of
+    Just val -> fromValue val
+    Nothing  -> throwError $ printf "Could not find field '%s'" (T.unpack name)
+
+instance MongoValue BSON.Value where
+  toValue = id
+  fromValue = return . id
+
+instance MongoValue BSON.Document where
+  toValue                = BSON.Doc
+  fromValue (BSON.Doc d) = pure d
+  fromValue v            = expected "Document" v
+
+instance MongoValue () where
+  toValue _           = BSON.Null
+  fromValue BSON.Null = pure ()
+  fromValue v         = expected "null" v
+
+instance MongoValue Bool where
+  toValue                  = BSON.Bool
+  fromValue (BSON.Bool x)  = pure x
+  fromValue v              = expected "boolean" v
+
+instance MongoValue BSON.UString where
+  toValue                              = BSON.String
+  fromValue (BSON.String x           ) = pure x
+  fromValue (BSON.Sym (BSON.Symbol x)) = pure x
+  fromValue v                          = expected "string or symbol" v
+
+instance MongoValue T.Text where
+  toValue                              = BSON.String . textToCompactString
+  fromValue (BSON.String x           ) = pure $! compactStringToText x
+  fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToText x
+  fromValue v                          = expected "string or symbol" v
+
+instance MongoValue LT.Text where
+  toValue                              = BSON.String . lazyTextToCompactString
+  fromValue (BSON.String x           ) = pure $! compactStringToLazyText x
+  fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToLazyText x
+  fromValue v                          = expected "string or symbol" v
+
+instance MongoValue (Maybe BSON.Value) where
+  toValue Nothing  = BSON.Null
+  toValue (Just x) = x
+  
+  fromValue BSON.Null = pure Nothing
+  fromValue x         = pure (Just x)
+
+instance (MongoValue a) => MongoValue (Maybe a) where
+  toValue Nothing  = BSON.Null
+  toValue (Just x) = toValue x
+  
+  fromValue BSON.Null = pure Nothing
+  fromValue x         = Just <$> (fromValue x)
+
+
+instance (MongoValue a) => MongoValue [a] where
+  toValue                  = BSON.Array . map toValue
+  fromValue (BSON.Array x) = mapM fromValue x
+  fromValue v              = expected "array" v
+
+instance (MongoValue a, MongoValue b) => MongoValue (Either a b) where
+  toValue (Left  x) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Left" ), "value" := toValue x ]
+  toValue (Right y) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Right"), "value" := toValue y ]
+  
+  fromValue (BSON.Doc doc) = do
+    side <- fmap (map toLower) $ BSON.lookup "_type" doc
+    case side of
+      ("left"  :: String) -> (return .  Left) =<< fromValue =<< BSON.look "value" doc
+      ("right" :: String) -> (return . Right) =<< fromValue =<< BSON.look "value" doc
+      other              -> throwError $ "Expected either 'left' or 'right', found '" ++ other ++ "'"
+  fromValue v = expected "document" v
+
+roundTo :: (RealFrac a) => a -> a -> a
+roundTo mult n = fromIntegral (round (n / mult)) * mult
+
+instance MongoValue UTCTime where
+  toValue                = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000) . utcTimeToPOSIXSeconds
+  fromValue (BSON.UTC x) = pure x
+  fromValue v            = expected "UTCTime" v
+
+instance MongoValue POSIXTime where
+  toValue                = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000)
+  fromValue (BSON.UTC x) = pure $! utcTimeToPOSIXSeconds x
+  fromValue v            = expected "UTCTime" v
+
+instance MongoValue BS.ByteString where
+  toValue                              = BSON.Bin . BSON.Binary
+  fromValue (BSON.Bin (BSON.Binary x)) = pure x
+  fromValue v                          = expected "binary" v
+
+instance MongoValue BSL.ByteString where
+  toValue                              = BSON.Bin . BSON.Binary . BS.concat . BSL.toChunks
+  fromValue (BSON.Bin (BSON.Binary x)) = pure $! BSL.fromChunks [x]
+  fromValue v                          = expected "binary" v
+
+
+
+fitInt :: forall m b a. (Applicative m, Monad m, PrintfArg a, Integral a, Integral b, Bounded b) => String -> a -> ErrorT String m b
+fitInt t n =
+  let l = minBound :: b
+      h = maxBound :: b
+  in if fromIntegral l <= n && n <= fromIntegral h
+        then pure $! fromIntegral n
+        else throwError $ printf "Integer value %i was out of range for type %s" n t
+
+
+instance MongoValue Int32 where
+  toValue                  = BSON.Int32
+  fromValue (BSON.Int32 x) = pure x
+  fromValue (BSON.Int64 x) = fitInt "Int32" x
+  fromValue (BSON.Float x) = pure $! round x
+  fromValue v              = expected "Int32, Int64 or Float" v
+
+instance MongoValue Int64 where
+  toValue                  = BSON.Int64
+  fromValue (BSON.Int32 x) = pure $! fromIntegral x
+  fromValue (BSON.Int64 x) = pure x
+  fromValue (BSON.Float x) = pure $! round x
+  fromValue v              = expected "Int32, Int64 or Float" v
+
+instance MongoValue Int where
+  toValue                  = BSON.Int64 . fromIntegral
+  fromValue (BSON.Int32 x) = pure $! fromIntegral x
+  fromValue (BSON.Int64 x) = pure $! fromEnum x
+  fromValue (BSON.Float x) = pure $! round x
+  fromValue v              = expected "Int32, Int64 or Float" v
+
+instance MongoValue Integer where
+  toValue                  = BSON.Int64 . fromIntegral
+  fromValue (BSON.Int32 x) = pure $! fromIntegral x
+  fromValue (BSON.Int64 x) = pure $! fromIntegral x
+  fromValue (BSON.Float x) = pure $! round x
+  fromValue v              = expected "Int32, Int64 or Float" v
+
+instance MongoValue Float where 
+  toValue                  = BSON.Float . realToFrac
+  fromValue (BSON.Float x) = pure $! realToFrac x
+  fromValue (BSON.Int32 x) = pure $! fromIntegral x
+  fromValue (BSON.Int64 x) = pure $! fromIntegral x
+  fromValue v              = expected "Int32, Int64 or Float" v
+
+instance MongoValue Double where
+  toValue                  = BSON.Float
+  fromValue (BSON.Float x) = pure x
+  fromValue (BSON.Int32 x) = pure $! fromIntegral x
+  fromValue (BSON.Int64 x) = pure $! fromIntegral x
+  fromValue v              = expected "Int32 or Int64" v
+  
+instance MongoValue ObjectId where
+  toValue                  = BSON.ObjId
+  fromValue (BSON.ObjId x) = pure x
+  fromValue v              = expected "ObjectId" v
+
+instance (MongoValue a, MongoValue b) => MongoValue (a, b) where
+  toValue (x, y)            = BSON.Array [toValue x, toValue y]
+  fromValue v @ (BSON.Array xs) =
+    case xs of
+      [x, y] -> (,) <$> fromValue x <*> fromValue y
+      _      -> expected "Array (with 2 elements)" v
+  fromValue v               = expected "Array (with 2 elements)" v
+
+instance (MongoValue a, MongoValue b, MongoValue c) => MongoValue (a, b, c) where
+  toValue (x, y, z)         = BSON.Array [toValue x, toValue y, toValue z]
+  fromValue v @ (BSON.Array xs) =
+    case xs of
+      [x, y, z] -> (,,) <$> fromValue x <*> fromValue y <*> fromValue z
+      _         -> expected "Array (with 3 elements)" v
+  fromValue v               = expected "Array (with 3 elements)" v
+
+
+-- | Instance of the 'MongoValue' type class for a map of strict 'T.Text' to some value which also an instance of the
+-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys.
+--
+-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of:
+-- @{ cat: 1, dog: 2, mat: 3 }@.
+--
+instance (MongoValue val) => MongoValue (M.Map T.Text val) where
+  toValue m = BSON.Doc $ map (\(k, v) -> textToCompactString k := toValue v) $ M.toList m
+  fromValue (BSON.Doc m) = do
+    elements <- mapM (\ (k := v) -> do
+                         val <- fromValue v
+                         pure (compactStringToText k, val)) m
+    pure $! M.fromList elements
+  fromValue v = expected "Document" v
+
+-- | Instance of the 'MongoValue' type class for a map of lazy 'LT.Text' to some value which also an instance of the
+-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys.
+--
+-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of:
+-- @{ cat: 1, dog: 2, mat: 3 }@.
+--
+instance (MongoValue val) => MongoValue (M.Map LT.Text val) where
+  toValue m = BSON.Doc $ map (\(k, v) -> lazyTextToCompactString k := toValue v) $ M.toList m
+  fromValue (BSON.Doc m) = do
+    elements <- mapM (\ (k := v) -> do
+                         val <- fromValue v
+                         pure (compactStringToLazyText k, val)) m
+    pure $! M.fromList elements
+  fromValue v = expected "Document" v
+
+
+instance (Ord key, MongoValue key, MongoValue val) => MongoValue (M.Map key val) where
+  toValue = toValue . M.toList
+  fromValue v = M.fromList <$> fromValue v
+    
+
+
+compactStringToText :: CS.CompactString -> T.Text
+compactStringToText = T.decodeUtf8 . CS.toByteString
+
+textToCompactString :: T.Text -> CS.CompactString
+textToCompactString = CS.fromByteString_ . T.encodeUtf8
+
+compactStringToLazyText :: CS.CompactString -> LT.Text
+compactStringToLazyText =
+  LT.decodeUtf8 . (\x -> BSL.fromChunks [x]) . CS.toByteString
+
+lazyTextToCompactString :: LT.Text -> CS.CompactString
+lazyTextToCompactString =
+  CS.fromByteString_ . BS.concat . BSL.toChunks . LT.encodeUtf8
+
+-- Local Variables:
+-- mode                  : Haskell
+-- fill-column           : 120
+-- default-justification : left
+-- End:

src/Snap/Snaplet/MongoDB/Parse.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-missing-fields #-}
+-- |
+-- Module      : Snap.Snaplet.MongoDB.Parse
+-- Description : Parser for MongoDB documents.
+-- Copyright   : (C) 2011 Massive Tactical Limited
+-- License     : BSD3
+--
+-- Maintainer  : Blake Rain <blake.rain@massivetactical.com>
+-- Stability   : Provisional
+-- Portability : Portable
+--
+-- Provides a quasi-quote parser for MongoDB documents.
+--
+
+module Snap.Snaplet.MongoDB.Parse
+       ( mongo
+       ) where
+
+import           Control.Applicative
+--import qualified Data.Bson as BSON
+--import           Data.Bson (Field ((:=)))
+import           Data.Char (isSpace, digitToInt)
+import           Data.Text (Text)
+import           Language.Haskell.TH.Syntax
+import           Language.Haskell.TH.Syntax.Internals
+import           Language.Haskell.TH.Quote
+import qualified Language.Haskell.Exts as H
+import           Snap.Snaplet.MongoDB.MongoValue
+import           Snap.Snaplet.MongoDB.MongoEntity
+import           Text.Parsec hiding (many, (<|>))
+
+mongo :: QuasiQuoter
+mongo = QuasiQuoter { quoteExp = mongoQuote }
+
+mongoQuote :: String -> Q Exp
+mongoQuote input = do
+  expr <- runParserT parseMongo () "" input
+  case expr of
+    Left err -> error $ show err
+    Right  e -> return e
+
+
+type Parser = ParsecT String () Q
+
+parseMongo :: Parser Exp
+parseMongo = do
+  doc <- whitespace *> topObjectDef
+  return ((VarE 'toDocument) `AppE` doc)
+  where
+    topObjectDef =
+      singleField <|> multipleFields
+    singleField =
+      (ListE . (: [])) <$> objectField
+    multipleFields =
+      objectDef
+
+whitespace :: Parser ()
+whitespace =
+  skipMany . satisfy $ isSpace
+
+lexeme :: Parser a -> Parser a
+lexeme p =
+  p <* whitespace
+
+objectDef :: Parser Exp
+objectDef =
+     (lexeme (char '{') <?> "'{' at start of JSON object")
+  *> (lexeme objectFields) <*
+     (lexeme (char '}') <?> "'}' at end of JSON object")
+
+objectFields :: Parser Exp
+objectFields = do
+  ListE <$> sepBy objectField (lexeme $ char ',')
+
+objectField :: Parser Exp
+objectField = do
+  name  <- lexeme (identifier <|> stringLiteral) <?> "identifier for field definition"
+  _     <- lexeme (char ':')
+  val   <- lexeme (fieldValue <|> arrayValue <|> objectDef) <?> ("value for field `" ++ name ++ "'")
+  
+  return (InfixE (Just . LitE . StringL $ name)
+                 (ConE '(:=))
+                 (Just (AppE (VarE 'toValue) val)))
+
+arrayValue :: Parser Exp
+arrayValue = do
+     (lexeme (char '[') <?> "'[' at start of JSON array")
+  *> (lexeme arrayElements) <*
+     (lexeme (char ']') <?> "']' at end of JSON array")
+  where
+    arrayElements = 
+      ListE . map ((VarE 'toValue) `AppE`) <$> sepBy (fieldValue <|> arrayValue <|> objectDef) (lexeme $ char ',')
+     
+
+fieldValue :: Parser Exp
+fieldValue = do
+  (stringValue <|> altBaseIntegerValue <|> numericalValue <|> boolNullValue <|> pasteValue) <?> "field value"
+  where
+    stringValue =
+      ((`SigE` (ConT ''Text)) . LitE . StringL) <$> stringLiteral
+
+    numericalValue = do
+      int <- decimal
+      rl  <- do
+        (Left . (+ fromIntegral int) <$> denom) <|> pure (Right int)
+      mEx <- option Nothing (Just <$> (oneOf "eE" *> (option id ((char '-' *> pure negate) <|> (char '+' *> pure id)) <*> decimal)))
+      case mEx of
+        Just ex -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL. toRational $ either id fromIntegral rl * (10 ** fromIntegral ex))
+        Nothing -> 
+          case rl of
+            Left  f -> pure $! ((`SigE` (ConT  ''Double)) . LitE . RationalL . toRational $ f)
+            Right i -> pure $! ((`SigE` (ConT ''Integer)) . LitE . IntegerL               $ i)
+    altBaseIntegerValue =
+      ((`SigE` (ConT ''Integer)) . LitE . IntegerL) <$> (hexadecimal <|> octal <|> binary)
+    hexadecimal = try (char '0' *> oneOf "xX" *> numberBuilder 16 hexDigit)
+    octal       = try (char '0' *> oneOf "oO" *> numberBuilder  8 octDigit)
+    binary      = try (char '0' *> oneOf "bB" *> numberBuilder 2 (char '0' <|> char '1'))
+    denom =
+      let op = ((/ 10) .) . ((+) . (fromIntegral . digitToInt))
+      in pure (foldr op 0.0) <*> (char '.' *> many1 digit)
+    
+    boolNullValue =
+      identifier >>= (\i -> case i of
+                             "true"  -> pure . ConE $ 'True
+                             "false" -> pure . ConE $ 'False
+                             "null"  -> pure . ConE $ '()
+                             _       -> unexpected i)
+    pasteValue = do
+      text <- (char '#' *> betweenBraces)
+      case H.parseExp text of
+        H.ParseOk       expr -> return (mapExpToTH expr)
+        H.ParseFailed _ msg  -> parserFail msg
+  
+betweenBraces :: Parser String
+betweenBraces = do
+  between (char '{') (char '}') (concat <$> many insideBraces)
+  where
+    insideBraces = do
+      ((\s -> '{' : s ++ "}") <$> betweenBraces) <|> ((: []) <$> satisfy (/= '}'))
+
+
+identifier :: Parser String
+identifier =
+  try (ident <?> "identifier")
+  where
+    ident = do
+      c  <- (letter <|> char '_' <|> char '$')
+      cs <- many (alphaNum <|> char '_')
+      return (c : cs)
+
+
+stringLiteral :: Parser String
+stringLiteral =
+  (do
+      str <- between (char '"')
+                    (char '"' <?> "end of string")
+                    (many stringChar)
+      return . foldr (maybe id (:)) "" $ str) <?> "string literal"
+
+stringChar :: Parser (Maybe Char)
+stringChar =
+  ( do
+       c <- stringLetter
+       return $ Just c) <|> stringEscape <?> "string character"
+
+stringLetter :: Parser Char
+stringLetter =
+  satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
+
+stringEscape :: Parser (Maybe Char)
+stringEscape =
+  char '\\' *> ((escapeGap   *> return Nothing) <|>
+                (escapeEmpty *> return Nothing) <|>
+                (Just <$> escapeCode          ))
+  where
+    escapeEmpty = char '&'
+    escapeGap   = many1 space >> (char '\\' <?> "end of string gap")
+    escapeCode  = charEsc <|> charNum <|> charAscii <|> charControl <?> "escape code"
+    
+    charControl = char '^' *> ((\c -> toEnum (fromEnum c - fromEnum 'A')) <$> upper)
+    charNum     =
+      (toEnum . fromInteger) <$> (decimal <|> (char 'o' *> numberBuilder  8 octDigit)
+                                          <|> (char 'x' *> numberBuilder 16 hexDigit))
+    charEsc     =
+      choice (map parseEsc escMap)
+      where
+        parseEsc (c, code) = char c *> pure code
+    
+    charAscii   =
+      choice (map parseAscii asciiMap)
+      where
+        parseAscii (asc, code) = try (string asc *> pure code)
+    
+    escMap      = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"
+    asciiMap    = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
+
+    ascii2codes = [ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "EM", "FS", 
+                    "GS", "RS", "US", "SP" ]
+    ascii3codes = [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "DLE",
+                    "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "SUB",
+                    "ESC", "DEL" ]
+    ascii2      = [ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI', '\EM',
+                    '\FS', '\GS', '\RS', '\US', '\SP' ]
+    ascii3      = [ '\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
+                    '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
+                    '\CAN', '\SUB', '\ESC', '\DEL' ]
+
+
+numberBuilder :: Integer -> Parser Char -> Parser Integer
+numberBuilder base baseDigit = do
+  digits <- many1 baseDigit
+  let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits
+  seq n (return n)
+
+decimal :: Parser Integer
+decimal = numberBuilder 10 digit
+  
+
+------------------------------------------------------------------------------------------------------------------------
+
+
+mapQName :: H.QName -> Name
+mapQName (H.Qual modu name) = Name (OccName $ strFromName name) (NameQ (ModName $ strFromModule modu))
+mapQName (H.UnQual    name) = mkName (strFromName name)
+mapQName (H.Special    con) = 
+  case con of
+    H.UnitCon          -> '()
+    H.ListCon          -> '[]
+    H.FunCon           -> mkName "(->)"
+    H.TupleCon _ n     -> mkName ('(' : replicate n ',' ++ ")")
+    H.Cons             -> '(:)
+--    H.UnboxedSingleCon -> '(# #)
+    H.UnboxedSingleCon -> error "No name for unboxed constructor"
+
+mapName :: H.Name -> Name
+mapName = mkName . strFromName
+
+strFromName :: H.Name -> String
+strFromName (H.Ident str) = str
+strFromName (H.Symbol op) = op
+
+strFromModule :: H.ModuleName -> String
+strFromModule (H.ModuleName name) = name
+
+mapDecl :: H.Decl -> [Dec]
+mapDecl (H.TypeDecl _ name binds typ) = [TySynD (mapName name) (map mapTypeBind binds) (mapTypeToTH typ)]
+mapDecl (H.TypeFamDecl _ name binds mKind) = [FamilyD TypeFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)]
+mapDecl (H.DataDecl _ H.DataType ctx name binds qConDecl deriv) = [DataD (mapContext ctx) (mapName name) (map mapTypeBind binds)
+                                                                         (map mapQCon qConDecl) (map (mapQName . fst) deriv)]
+mapDecl (H.DataDecl _ H.NewType  ctx name binds qConDecl deriv) = [NewtypeD (mapContext ctx) (mapName name) (map mapTypeBind binds)
+                                                                            (mapQCon (head qConDecl)) (map (mapQName . fst) deriv)]
+mapDecl (H.GDataDecl _ _ _ _ _ _ _ _) = error "No support for GADTs in Template Haskell"
+mapDecl (H.DataFamDecl _ _ name binds mKind) = [FamilyD DataFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)]
+mapDecl (H.TypeInsDecl _ _ _) = error "No support for type instances"
+mapDecl (H.DataInsDecl _ H.DataType _ _ _) = error "No support for data instances"
+mapDecl (H.DataInsDecl _ H.NewType  _   _        _    ) = error "No support for data instances"
+mapDecl (H.GDataInsDecl _ _ _ _ _ _) = error "No support for GADTs in Template Haskell"
+mapDecl (H.ClassDecl _ ctx name binds funDeps classDecls) = [ClassD (mapContext ctx) (mapName name) (map mapTypeBind binds)
+                                                                    (map mapFunDep funDeps) (map mapClassDecl classDecls)]
+mapDecl (H.InstDecl _ ctx _ types instDecls) = [InstanceD (mapContext ctx) (mapTypeToTH (head types)) (map mapInstDecl instDecls)]
+mapDecl (H.DerivDecl _ _ _ _) = error "No support for standalone deriving declarations in Template Haskell"
+mapDecl (H.InfixDecl _ _ _ _) = error "No support for operator fixity declarations in Template Haskell"
+mapDecl (H.DefaultDecl _ _) = error "No support for default declarations in Template Haskell"
+mapDecl (H.SpliceDecl _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
+mapDecl (H.TypeSig _ names typ) = map (flip SigD (mapTypeToTH typ) . mapName) names
+mapDecl (H.FunBind matches) = [FunD (matchName (head matches)) (map mapClause matches)]
+mapDecl (H.PatBind _ pat _ rhs binds) = [ValD (mapPatToTH pat) (mapRhs rhs) (mapBinds binds)]
+mapDecl (H.ForImp _ cc safe str name typ) = [ForeignD (ImportF (mapCC cc) (mapSafety safe) str (mapName name) (mapTypeToTH typ))]
+mapDecl (H.ForExp _ cc str name typ) = [ForeignD (ExportF (mapCC cc) str (mapName name) (mapTypeToTH typ))]
+mapDecl (H.RulePragmaDecl _ _) = error "No support for RULES pragma in Template Haskell"
+mapDecl (H.DeprPragmaDecl _ _) = error "No support for DEPRECATED pragma in Template Haskell"
+mapDecl (H.WarnPragmaDecl _ _) = error "No support for WARNING pragma in Template Haskell"
+mapDecl (H.InlineSig _ _ _ name) = [PragmaD (InlineP (mapQName name) (InlineSpec True False Nothing))]
+mapDecl (H.InlineConlikeSig _ _ _) = error "No current support for INLINE CONLIKE pragma"
+mapDecl (H.SpecSig _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) Nothing)]
+mapDecl (H.SpecInlineSig _ _ _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) (Just (InlineSpec True False Nothing)))]
+mapDecl (H.InstSig _ _ _ _) = error "No support for SPECIALISE instance pragma in Template Haskell (I think...)"
+mapDecl (H.AnnPragma _ _) = error "No support for ANN pragma in Template Haskell"
+
+mapCC :: H.CallConv -> Callconv
+mapCC (H.StdCall) = StdCall
+mapCC (H.CCall  ) = CCall
+
+mapSafety :: H.Safety -> Safety
+mapSafety (H.PlayRisky ) = Unsafe
+mapSafety (H.PlaySafe t) = if t then Threadsafe else Safe
+                                                      
+matchName :: H.Match -> Name
+matchName (H.Match _ name _ _ _ _) = mapName name
+
+mapClause :: H.Match -> Clause
+mapClause (H.Match _ _ pats _ rhs binds) = Clause (map mapPatToTH pats) (mapRhs rhs) (mapBinds binds)
+
+mapRhs :: H.Rhs -> Body
+mapRhs (H.UnGuardedRhs     e) = NormalB (mapExpToTH e)
+mapRhs (H.GuardedRhss guards) =
+  GuardedB (map mapGRhs guards)
+  where
+    mapGRhs (H.GuardedRhs _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e)
+
+  
+mapInstDecl :: H.InstDecl -> Dec
+mapInstDecl (H.InsDecl decl) = head (mapDecl decl)
+mapInstDecl _                = error "Unsupported"
+
+mapClassDecl :: H.ClassDecl -> Dec
+mapClassDecl (H.ClsDecl decl) = head (mapDecl decl)
+mapClassDecl _                = error "Unsupported"
+
+mapFunDep :: H.FunDep -> FunDep
+mapFunDep (H.FunDep xs ys) = FunDep (map mapName xs) (map mapName ys)
+
+mapQCon :: H.QualConDecl -> Con
+mapQCon (H.QualConDecl _ []    []  conDecl) = mapCon conDecl
+mapQCon (H.QualConDecl _ binds ctx conDecl) = ForallC (map mapTypeBind binds) (mapContext ctx) (mapCon conDecl)
+
+mapCon :: H.ConDecl -> Con
+mapCon (H.ConDecl     name args) = NormalC (mapName name) (map mapBangType args)
+mapCon (H.InfixConDecl x name y) = InfixC (mapBangType x) (mapName name) (mapBangType y)
+mapCon (H.RecDecl   name fields) = RecC (mapName name) $ map (uncurry mapFieldDecl) $ concatMap (uncurry ((. repeat) . zip)) fields
+
+mapFieldDecl :: H.Name -> H.BangType -> VarStrictType
+mapFieldDecl name bType = let (strict, typ) = mapBangType bType
+                          in (mapName name, strict, typ)
+
+mapBangType :: H.BangType -> StrictType
+mapBangType (H.BangedTy   t) = (IsStrict,  mapTypeToTH t)
+mapBangType (H.UnBangedTy t) = (NotStrict, mapTypeToTH t)
+mapBangType (H.UnpackedTy _) = error "No support for unboxed type (via UNPACK pragma) in Template Haskell"
+
+
+mapExpToTH :: H.Exp -> Exp
+mapExpToTH (H.Var             name) = VarE (mapQName name)
+mapExpToTH (H.IPVar              _) = error "No implicit parameter support"
+mapExpToTH (H.Con             name) = ConE (mapQName name)
+mapExpToTH (H.Lit              lit) = LitE (mapLitToTH lit)
+mapExpToTH (H.InfixApp      l op r) = InfixE (Just $ mapExpToTH l) (mapQOpToTH op) (Just $ mapExpToTH r)
+mapExpToTH (H.App              l r) = (mapExpToTH l) `AppE` (mapExpToTH r)
+mapExpToTH (H.NegApp             o) = AppE (VarE 'negate) (mapExpToTH o)
+mapExpToTH (H.Lambda       _ pat e) = LamE (map mapPatToTH pat) (mapExpToTH e)
+mapExpToTH (H.Let             bs e) = LetE (mapBinds bs) (mapExpToTH e)
+mapExpToTH (H.If             e t f) = CondE (mapExpToTH e) (mapExpToTH t) (mapExpToTH f)
+mapExpToTH (H.Case            e ms) = CaseE (mapExpToTH e) (map mapAlt ms)
+mapExpToTH (H.Do                 s) = DoE (map mapStmt s)
+mapExpToTH (H.MDo                _) = error "No support for mdo expressions"
+mapExpToTH (H.Tuple             es) = TupE (map mapExpToTH es)
+mapExpToTH (H.TupleSection       _) = error "Tuple sections currently not supported by template haskell"
+mapExpToTH (H.List              es) = ListE (map mapExpToTH es)
+mapExpToTH (H.Paren              e) = mapExpToTH e
+mapExpToTH (H.LeftSection      e o) = InfixE (Just (mapExpToTH e)) (mapQOpToTH o) Nothing
+mapExpToTH (H.RightSection     o e) = InfixE Nothing (mapQOpToTH o) (Just (mapExpToTH e))
+mapExpToTH (H.RecConstr       n fs) = RecConE (mapQName n) (map mapFieldUpdate fs)
+mapExpToTH (H.RecUpdate       e fs) = RecUpdE (mapExpToTH e) (map mapFieldUpdate fs)
+mapExpToTH (H.EnumFrom           e) = ArithSeqE (FromR (mapExpToTH e))
+mapExpToTH (H.EnumFromTo       x y) = ArithSeqE (FromToR (mapExpToTH x) (mapExpToTH y))
+mapExpToTH (H.EnumFromThen     x y) = ArithSeqE (FromThenR (mapExpToTH x) (mapExpToTH y))
+mapExpToTH (H.EnumFromThenTo x y z) = ArithSeqE (FromThenToR (mapExpToTH x) (mapExpToTH y) (mapExpToTH z))
+mapExpToTH (H.ListComp        e qs) = CompE (map mapQualStmt qs ++ [NoBindS $ mapExpToTH e])
+mapExpToTH (H.ParComp          _ _) = error "No support for parallel list comprehensions in Template Haskell"
+mapExpToTH (H.ExpTypeSig     _ e t) = SigE (mapExpToTH e) (mapTypeToTH t)
+mapExpToTH (H.VarQuote           _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
+mapExpToTH (H.TypQuote           _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
+mapExpToTH (H.BracketExp         _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
+mapExpToTH (H.SpliceExp          _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
+mapExpToTH (H.QuasiQuote       _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
+mapExpToTH (H.XTag       _ _ _ _ _) = error "No support for XML extension in Template Haskell"
+mapExpToTH (H.XETag        _ _ _ _) = error "No support for XML extension in Template Haskell"
+mapExpToTH (H.XPcdata            _) = error "No support for XML extension in Template Haskell"
+mapExpToTH (H.XExpTag            _) = error "No support for XML extension in Template Haskell"
+mapExpToTH (H.XChildTag        _ _) = error "No support for XML extension in Template Haskell"
+mapExpToTH (H.CorePragma       _ _) = error "No support for pragmas in Template Haskell"
+mapExpToTH (H.SCCPragma        _ _) = error "No support for pragmas in Template Haskell"
+mapExpToTH (H.GenPragma    _ _ _ _) = error "No support for pragmas in Template Haskell"
+mapExpToTH (H.Proc           _ _ _) = error "No support for arrows 'proc' in Template Haskell"
+mapExpToTH (H.LeftArrApp       _ _) = error "No support for left arrow application in Template Haskell"
+mapExpToTH (H.RightArrApp      _ _) = error "No support for right arrow application in Template Haskell"
+mapExpToTH (H.LeftArrHighApp   _ _) = error "No support for higher-order left arrow application in Template Haskell"
+mapExpToTH (H.RightArrHighApp  _ _) = error "No support for higher-order right arrow application in Template Haskell"
+
+
+mapQualStmt :: H.QualStmt -> Stmt
+mapQualStmt (H.QualStmt stmt) = mapStmt stmt
+mapQualStmt _                 = error "No support for SQL-like generalized list comprehensions (not supported by Template Haskell)"
+
+mapFieldUpdate :: H.FieldUpdate -> FieldExp
+mapFieldUpdate (H.FieldUpdate n e) = (mapQName n, mapExpToTH e)
+mapFieldUpdate (H.FieldPun      _) = error "No support for field puns in update expressions"
+mapFieldUpdate (H.FieldWildcard  ) = error "No support for field wildcards in update expressions"
+
+mapAlt :: H.Alt -> Match
+mapAlt (H.Alt _ p g bs) = Match (mapPatToTH p) (mapGuard g) (mapBinds bs)
+
+mapGuard :: H.GuardedAlts -> Body
+mapGuard (H.UnGuardedAlt e) = NormalB (mapExpToTH e)
+mapGuard (H.GuardedAlts gs) =
+  GuardedB (map mapGAlt gs)
+  where
+    mapGAlt (H.GuardedAlt _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e)
+
+mapStmt :: H.Stmt -> Stmt
+mapStmt (H.Generator _ p e) = BindS (mapPatToTH p) (mapExpToTH e)
+mapStmt (H.Qualifier     e) = NoBindS (mapExpToTH e)
+mapStmt (H.LetStmt      bs) = LetS (mapBinds bs)
+mapStmt (H.RecStmt      rs) = ParS [map mapStmt rs]
+
+mapBinds :: H.Binds -> [Dec]
+mapBinds (H.BDecls decls) = concatMap mapDecl decls
+mapBinds (H.IPBinds    _) = error "No support for implicit parameter bindings"
+
+mapQOpToTH :: H.QOp -> Exp
+mapQOpToTH (H.QVarOp name) = VarE (mapQName name)
+mapQOpToTH (H.QConOp name) = ConE (mapQName name)
+
+{-
+mapQOpToTHT :: H.QOp -> Type
+mapQOpToTHT (H.QVarOp name) = VarT (mapQName name)
+mapQOpToTHT (H.QConOp name) = ConT (mapQName name)
+-}
+
+mapPatToTH :: H.Pat -> Pat
+mapPatToTH (H.PVar        name) = VarP (mapName name)
+mapPatToTH (H.PLit         lit) = LitP (mapLitToTH lit)
+mapPatToTH (H.PNeg           _) = error "What?! (http://trac.haskell.org/haskell-src-exts/ticket/209)"
+mapPatToTH (H.PNPlusK      _ _) = error "No support for N+K patterns"
+mapPatToTH (H.PInfixApp  l n r) = InfixP (mapPatToTH l) (mapQName n) (mapPatToTH r)
+mapPatToTH (H.PApp         n p) = ConP (mapQName n) (map mapPatToTH p)
+mapPatToTH (H.PTuple         p) = TupP (map mapPatToTH p)
+mapPatToTH (H.PList          p) = ListP (map mapPatToTH p)
+mapPatToTH (H.PParen         p) = mapPatToTH p
+mapPatToTH (H.PRec        n pf) = RecP (mapQName n) (map mapPatFieldToTH pf)
+mapPatToTH (H.PAsPat       n p) = AsP (mapName n) (mapPatToTH p)
+mapPatToTH (H.PWildCard       ) = WildP
+mapPatToTH (H.PIrrPat        p) = TildeP (mapPatToTH p)
+mapPatToTH (H.PatTypeSig _ p t) = SigP (mapPatToTH p) (mapTypeToTH t)
+mapPatToTH (H.PViewPat     _ _) = error "No support for view patterns"
+mapPatToTH (H.PRPat          _) = error "I don't know what a PR pattern is"
+mapPatToTH (H.PXTag  _ _ _ _ _) = error "No support for XML"
+mapPatToTH (H.PXETag   _ _ _ _) = error "No support for XML"
+mapPatToTH (H.PXPcdata       _) = error "No support for XML"
+mapPatToTH (H.PXPatTag       _) = error "No support for XML"
+mapPatToTH (H.PXRPats        _) = error "No support for XML"
+mapPatToTH (H.PExplTypeArg _ _) = error "No support for explicit type arguments"
+mapPatToTH (H.PQuasiQuote  _ _) = error "No support for quasi-quotation"
+mapPatToTH (H.PBangPat       _) = error "No support for bang patterns"
+
+mapTypeToTH :: H.Type -> Type
+mapTypeToTH (H.TyForall vb ctx t) = ForallT (maybe [] (map mapTypeBind) vb) (mapContext ctx) (mapTypeToTH t)
+mapTypeToTH (H.TyFun         l r) = AppT (AppT ArrowT (mapTypeToTH l)) (mapTypeToTH r)
+mapTypeToTH (H.TyTuple      _ ts) = foldl AppT (TupleT (length ts)) (map mapTypeToTH ts)
+mapTypeToTH (H.TyList          t) = AppT ListT (mapTypeToTH t)
+mapTypeToTH (H.TyApp         l r) = AppT (mapTypeToTH l) (mapTypeToTH r)
+mapTypeToTH (H.TyVar           v) = VarT (mapName v)
+mapTypeToTH (H.TyCon           c) = ConT (mapQName c)
+mapTypeToTH (H.TyParen         t) = mapTypeToTH t
+mapTypeToTH (H.TyInfix    l op r) = AppT (AppT (ConT $ mapQName op) (mapTypeToTH l)) (mapTypeToTH r)
+mapTypeToTH (H.TyKind        _ _) = error "No support for types with explicit type kinds"
+
+mapTypeBind :: H.TyVarBind -> TyVarBndr
+mapTypeBind (H.KindedVar n k) = KindedTV (mapName n) (mapKind k)
+mapTypeBind (H.UnkindedVar n) = PlainTV (mapName n)
+
+mapKind :: H.Kind -> Kind
+mapKind (H.KindStar   ) = StarK
+mapKind (H.KindBang   ) = error "No support for bang-kinds"
+mapKind (H.KindFn  x y) = ArrowK (mapKind x) (mapKind y)
+mapKind (H.KindParen k) = mapKind k
+mapKind (H.KindVar   _) = error "No support for kind variables"
+
+mapContext :: H.Context -> Cxt
+mapContext =
+  map mapAssert
+  where
+    mapAssert (H.ClassA  q ts) = ClassP (mapQName q) (map mapTypeToTH ts)
+    mapAssert (H.InfixA x q y) = ClassP (mapQName q) [mapTypeToTH x, mapTypeToTH y]
+    mapAssert (H.IParam   _ _) = error "No support for implicit parameter assertion"
+    mapAssert (H.EqualP   x y) = EqualP (mapTypeToTH x) (mapTypeToTH y)
+
+mapPatFieldToTH :: H.PatField -> FieldPat
+mapPatFieldToTH (H.PFieldPat name pat) = (mapQName name, mapPatToTH pat)
+mapPatFieldToTH (H.PFieldPun        _) = error "field puns not yet supported"
+mapPatFieldToTH (H.PFieldWildcard    ) = (mkName "", WildP)
+
+mapLitToTH :: H.Literal -> Lit
+mapLitToTH (H.Char       c) = CharL       c
+mapLitToTH (H.String     s) = StringL     s
+mapLitToTH (H.Int        i) = IntegerL    i
+mapLitToTH (H.Frac       r) = RationalL   r
+mapLitToTH (H.PrimInt    i) = IntPrimL    i
+mapLitToTH (H.PrimWord   w) = WordPrimL   w
+mapLitToTH (H.PrimFloat  f) = FloatPrimL  f
+mapLitToTH (H.PrimDouble d) = DoublePrimL d
+mapLitToTH (H.PrimChar   c) = CharL       c
+mapLitToTH (H.PrimString s) = StringPrimL s
+
+
+
+-- Local Variables:
+-- mode                  : Haskell
+-- fill-column           : 120
+-- default-justification : left
+-- End:

src/Snap/Snaplet/MongoDB/Template.hs

+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+-- |
+-- Module      : Snap.Snaplet.MongoDB.Template
+-- Description : Template Haskell functions for creating MongoDB entities.
+-- Copyright   : (C) 2011 Massive Tactical Limited
+-- License     : BSD3
+--
+-- Maintainer  : Blake Rain <blake.rain@massivetactical.com>
+-- Stability   : Provisional
+-- Portability : Unknown
+--
+-- Various Template Haskell functions for creating MongoDB entities.
+--
+
+module Snap.Snaplet.MongoDB.Template
+       ( asMongoEntity
+       , useDefaults
+       , setCollectionName
+       , forConstructor
+       , ConstructorOp
+       , setConstructorName
+       , renameFields
+       , assocFieldNames
+       , indexedFieldName
+       , setFieldReadOnly
+       , asMongoValue
+       , encodedViaShow
+       ) where
+
+import           Control.Applicative
+import           Control.Monad.Error
+import           Control.Monad.State
+import           Control.Monad.Writer
+import qualified Data.Bson as BSON
+import           Data.Char (toUpper, toLower)
+import           Data.List (find)
+import           Data.Maybe (catMaybes)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Language.Haskell.TH.Syntax hiding (lift)
+import           Snap.Snaplet.MongoDB.MongoValue
+import           Snap.Snaplet.MongoDB.MongoEntity
+
+
+-- Represents a field declaration from the type we are to store.
+data FieldDecl = -- A field in a record data type constructor.
+                 FieldDecl { fieldName       :: Name    -- The actual name of the field.
+                           , fieldSimpleName :: String  -- The simple name of the field, as stored in the document (can be changed).
+                           , fieldType       :: Type
+                           , fieldReadOnly   :: Bool    -- If 'True', the field will not be output by the 'toDocument' function.
+                           }
+                 -- Represents a field in a 'NormalC' data type constructor.
+               | SimpleFieldDecl { simpleFieldName :: String
+                                 , simpleFieldType :: Type }
+
+-- Represents a constructor to a data type. We blend both 'NormalC' and 'RecordC' data type constructors into this type.
+data Constructor = Constructor { constrName       :: Name         -- The actual name of the constructor.
+                               , constrSimpleName :: String       -- The simple name of the constructor, as stored in the _type field in the document (can be changed).
+                               , constrBody       :: [FieldDecl]
+                               }
+
+-- The environment in which our template builder lives. This is actually used as _state_, but whatever.
+data TemplateEnv = TemplateEnv { envTypeName       :: Name            -- The name of the type we are generating a MongoEntity instance for.
+                               , envSimpleTypeName :: String          -- The simple name of the type.
+                               , envCollectionName :: String          -- The name of the collection to which we are to store this type.
+                               , envEncodedViaShow :: Bool            -- Is the 'MongoValue' instance encoded via Show/Read rather than toDocument/fromDocument?
+                               , envConstructors   :: [Constructor]
+                               }
+
+type EndoFunctor a = a -> a
+type TemplateGen = StateT TemplateEnv (WriterT (EndoFunctor [Dec]) Q)
+
+
+-- | This function is used to indicate to 'asMongoEntity' and 'asMongoValue' that the default behaviour is to be used.
+useDefaults :: TemplateGen ()
+useDefaults = return ()
+
+-- | This function generates an instance of the 'MongoEntity' and 'MongoValue' type classes for the specified type.
+asMongoEntity :: Name -> TemplateGen () -> Q [Dec]
+asMongoEntity typeName actions =
+  runTemplateGen typeName (actions >> genEntityInstance >> genValueInstance)
+
+-- | This function generates an instance of the 'MongoValue' type class for the given type. If the type is to be encoded
+-- via 'show' and 'read', then a 'MongoEntity' instance is /not/ created; otherwise one will be.
+asMongoValue :: Name -> TemplateGen () -> Q [Dec]
+asMongoValue typeName actions = do
+  runTemplateGen typeName $ do
+    actions
+    viaShow <- gets envEncodedViaShow
+    if viaShow then genValueViaShowInstance else (genEntityInstance >> genValueInstance)
+
+
+-- | Set the name of the collection to which the type is to be stored. By default, the name of the collection is the
+-- same as the name of the type.
+setCollectionName :: String -> TemplateGen ()
+setCollectionName newName =
+  modify (\s -> s { envCollectionName = newName })
+
+-- | Sets whether the 'MongoValue' instance for the type should be encoded via 'read' and 'show' rather than
+-- 'fromDocument' and 'toDocument'.
+encodedViaShow :: TemplateGen ()
+encodedViaShow =
+  modify (\s -> s { envEncodedViaShow = True })
+
+-- | Operations over constructors live in the 'ConstructorOp' monad.
+type ConstructorOp = StateT Constructor TemplateGen
+
+-- | For @foConstructor name ops@, perform @ops@ for the constructor matching @name@. This allows us to change the name
+-- of the constructor stored in the @_type@ field, and alter the behaviour of individual fields.
+forConstructor :: Name -> ConstructorOp () -> TemplateGen ()
+forConstructor name f = do
+  constrs <- dConstr name f =<< gets envConstructors
+  modify (\s -> s { envConstructors = constrs })
+  where
+    dConstr _    _       [] = return []
+    dConstr name f (x : xs)
+      | constrName x == name = do
+        (_, x') <- runStateT f x
+        return (x' : xs)
+      | otherwise           = do
+        xs' <- dConstr name f xs
+        return (x : xs')
+
+-- | Set the name stored in the @_type@ field of the document for the current constructor.
+setConstructorName :: String -> ConstructorOp ()
+setConstructorName newName = do
+  modify (\c -> c { constrSimpleName = newName })
+
+-- | Set the field with the specified name to read only. This will mean that the 'toDocument' function will not output
+-- this field. This means that the field's value will not be written to the document.
+setFieldReadOnly :: Name -> ConstructorOp ()
+setFieldReadOnly name =
+  modify (\c -> c { constrBody = dField name (constrBody c) })
+  where
+    dField _          [] = []
+    dField name (f : fs)
+      | fieldName f == name =
+        f { fieldReadOnly = True } : fs
+      | otherwise =
+        f : dField name fs
+
+-- | Change the names of a number of fields. The default behaviour is for the fields in the document to have the same
+-- name as the fields in the record type constructor.
+assocFieldNames :: [(Name, String)] -> ConstructorOp ()
+assocFieldNames assocs =
+  modify (\c -> c { constrBody = dField (constrBody c) })
+  where
+    dField               [] = []
+    dField (field : fields) =
+      case field of
+        FieldDecl name _ _ _ ->
+          (maybe field (\newName -> field { fieldSimpleName = newName }) $ lookup name assocs) : dField fields
+        SimpleFieldDecl name _ ->
+          let name' = mkName name in (maybe field (\newName -> field { simpleFieldName = newName }) $ lookup name' assocs) : dField fields
+
+-- | Renames fields in the order they are found in the type constructor.
+renameFields :: [String] -> ConstructorOp ()
+renameFields newNames =
+  modify (\c -> c { constrBody = zipWith renameField newNames (constrBody c) })