Source

snaplet-mongoDB / src / Snap / Snaplet / MongoDB.hs

Diff from to

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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.