structured-mongoDB (empty) → 0.1
raw patch · 9 files changed
+1071/−0 lines, 9 filesdep +arraydep +basedep +bsonsetup-changed
Dependencies added: array, base, bson, bytestring, compact-string-fix, containers, mongoDB, mtl, old-time, template-haskell, transformers
Files
- Database/MongoDB/Structured.hs +122/−0
- Database/MongoDB/Structured/Deriving/TH.hs +293/−0
- Database/MongoDB/Structured/Query.hs +372/−0
- Database/MongoDB/Structured/Types.hs +45/−0
- LICENSE +17/−0
- Setup.hs +3/−0
- examples/mongoExample.hs +93/−0
- examples/simple.hs +83/−0
- structured-mongoDB.cabal +43/−0
+ Database/MongoDB/Structured.hs view
@@ -0,0 +1,122 @@+-- | This module exports a /structued/ interface to MongoDB.+-- Specifically, Haskell record types are used (in place of BSON)+-- to represent documents which can be inserted and retrieved from+-- a MongoDB. Data types corresponding to fields of a document+-- are used in forming well-typed queries, as opposed to strings.+-- This module re-exports the "Database.MongoDB.Structured.Types"+-- module, which exports a 'Structured' type class --- this class is+-- used to convert Haskell record types to and from BSON documents.+-- The module "Database.MongoDB.Structured.Query" exports an+-- interface similar to @Database.MongoDB.Query@ which can be used to+-- insert, query, update, delete, etc. record types from a Mongo DB.+-- +-- Though users may provide their own instances for 'Structured'+-- (and 'Selectable', used in composing well-typed queries), we+-- provide a Template Haskell function ('deriveStructured')+-- that can be used to automatically do this. See+-- "Database.MongoDB.Structured.Deriving.TH".+--+-- The example below shows how to use the structued MongoDB interface:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > {-# LANGUAGE TypeSynonymInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE DeriveDataTypeable #-}+-- > import Database.MongoDB.Structured+-- > import Database.MongoDB.Structured.Deriving.TH+-- > import Control.Monad.Trans (liftIO)+-- > import Data.Typeable+-- > import Control.Monad (mapM_)+-- > import Control.Monad.IO.Class+-- > import Data.Bson (Value)+-- > import Data.Maybe (isJust, fromJust)+-- >+-- > data Address = Address { addrId :: SObjId+-- > , city :: String+-- > , state :: String+-- > } deriving (Show, Eq, Typeable)+-- > $(deriveStructured ''Address)+-- >+-- > data Team = Team { teamId :: SObjId+-- > , name :: String+-- > , home :: Address+-- > , league :: String+-- > } deriving (Show, Eq, Typeable)+-- > $(deriveStructured ''Team)+-- >+-- > main = do+-- > pipe <- runIOE $ connect (host "127.0.0.1")+-- > e <- access pipe master "baseball" run+-- > close pipe+-- > print e+-- >+-- > run = do+-- > clearTeams+-- > insertTeams+-- > allTeams >>= printDocs "All Teams"+-- > nationalLeagueTeams >>= printDocs "National League Teams"+-- > newYorkTeams >>= printDocs "New York Teams"+-- >+-- > -- Delete all teams:+-- > clearTeams :: Action IO ()+-- > clearTeams = delete (select ( (.*) :: QueryExp Team))+-- >+-- > insertTeams :: Action IO [Value]+-- > insertTeams = insertMany [+-- > Team { teamId = noSObjId+-- > , name = "Yankees"+-- > , home = Address { addrId = noSObjId+-- > , city = "New York"+-- > , state = "NY"+-- > }+-- > , league = "American"}+-- > , Team { teamId = noSObjId+-- > , name = "Mets"+-- > , home = Address { addrId = noSObjId+-- > , city = "New York"+-- > , state = "NY"+-- > }+-- > , league = "National"}+-- > , Team { teamId = noSObjId+-- > , name = "Phillies"+-- > , home = Address { addrId = noSObjId+-- > , city = "Philadelphia"+-- > , state = "PA"+-- > }+-- > , league = "National"}+-- > , Team { teamId = noSObjId+-- > , name = "Red Sox"+-- > , home = Address { addrId = noSObjId+-- > , city = "Boston"+-- > , state = "MA"+-- > }+-- > , league = "National"}+-- > ]+-- >+-- > allTeams :: Action IO [Maybe Team]+-- > allTeams = let query = (select ((.*) :: QueryExp Team))+-- > { sort = [asc (Home .! City)]}+-- > in find query >>= rest+-- > +-- > nationalLeagueTeams :: Action IO [Maybe Team]+-- > nationalLeagueTeams = rest =<< find (select (League .== "National"))+-- >+-- > newYorkTeams :: Action IO [Maybe Team]+-- > newYorkTeams = rest =<< find (select (Home .! State .== "NY"))+-- >+-- > printDocs :: MonadIO m => String -> [Maybe Team] -> m ()+-- > printDocs title teams' = liftIO $ do+-- > let teams = (map fromJust) . filter (isJust) $ teams'+-- > putStrLn title +-- > mapM_ (putStrLn . show) teams+--+module Database.MongoDB.Structured ( module Database.MongoDB.Structured.Types+ , module Database.MongoDB.Connection+ , module Database.MongoDB.Structured.Query+ ) where++import Database.MongoDB.Structured.Types+import Database.MongoDB.Connection+import Database.MongoDB.Structured.Query
+ Database/MongoDB/Structured/Deriving/TH.hs view
@@ -0,0 +1,293 @@+-- | This module exports a 'Structued' type class which can be used to+-- convert from Haskel \"record types\" to @BSON@ objects and vice versa.+-- We use Templace Haskell to provide a function 'deriveStructured'+-- which can be used to automatically generate an instance of such+-- types for the 'Structured' and BSON's @Val@ classes.+--+-- For instance:+--+-- > data User = User { userId :: Int+-- > , userFirstName :: String+-- > , userLastName :: String+-- > }+-- > deriving(Show, Read, Eq, Ord, Typeable)+-- > $(deriveStructured ''User)+-- > +--+-- 'deriveStrctured' used used to create the following instance of 'Structured':+--+-- > instance Structured User where+-- > toBSON x = [ (u "_id") := val (userId x)+-- > , (u "userFirstName") := val (userFirstName x)+-- > , (u "userLastName") := val (userLastName x)+-- > ]+-- > +-- > fromBSON doc = lookup (u "_id") doc >>= \val_1 ->+-- > lookup (u "userFirstName") doc >>= \val_2 ->+-- > lookup (u "userLastName") doc >>= \val_3 ->+-- > return User { userId = val_1+-- > , userFirstName = val_2+-- > , userLastname = val_3+-- > }+-- +-- To allow for structured and well-typed queies, it also generates+-- types corresponding to each field (which are made an instance of+-- 'Selectable'). Specifically, for the above data type, it creates:+-- +-- > data UserId = UserId deriving (Show, Eq)+-- > instance Selectable User UserId SObjId where s _ _ = "_id"+-- > +-- > data FirstName = FirstName deriving (Show, Eq)+-- > instance Selectable User FirstName String where s _ _ = "firstName"+-- > +-- > data LastName = LastName deriving (Show, Eq)+-- > instance Selectable User LastName String where s _ _ = "lastName"+--+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+module Database.MongoDB.Structured.Deriving.TH ( deriveStructured ) where++import Database.MongoDB.Structured.Query+import Database.MongoDB.Structured+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Data.Char (toUpper)+import Data.Bson+import qualified Data.Bson as BSON+import Data.Functor ((<$>))+import Data.List (isPrefixOf)++data T1 = T1+data T2 = T2+data T3 = T3++-- | This function generates 'Structured' and @Val@ instances for+-- record types.+deriveStructured :: Name -> Q [Dec]+deriveStructured t = do+ let className = ''Structured+ let collectionName = 'collection+ let toBSONName = 'toBSON+ let fromBSONName = 'fromBSON++ -- Get record fields:+ TyConI (DataD _ _ _ (RecC conName fields:[]) _) <- getFields t+ let fieldNames = map first fields+ sObjIds = lookForSObjId fields++ guardSObjId sObjIds+ let sObjName = (first . head) sObjIds++ collectionFunD <- funD_collection collectionName conName+ toBSONFunD <- funD_toBSON toBSONName fieldNames sObjName+ fromBSONFunD <- funD_fromBSON fromBSONName conName fieldNames sObjName+ + selTypesAndInst <- genSelectable t fields++ -- Generate Structured instance:+ let structuredInst = InstanceD [] (AppT (ConT className) (ConT t)) + [ collectionFunD+ , toBSONFunD+ , fromBSONFunD ]+ -- Generate Val instance:+ valInst <- gen_ValInstance t++ return $ [structuredInst, valInst] ++ selTypesAndInst+ where getFields t1 = do+ r <- reify t1+ case r of+ TyConI (DataD _ _ _ (RecC _ _:[]) _) -> return ()+ _ -> report True "Unsupported type. Can only derive for\+ \ single-constructor record types."+ return r+ lookForSObjId = filter f+ where f (_,_,(ConT n)) = (n == ''SObjId)+ f _ = False+ guardSObjId ids = if length ids /= 1+ then report True "Expecting 1 SObjId field."+ else return ()+ first (a,_,_) = a++-- | Generate the declaration for 'toBSON'.+--+-- Suppose we have+--+-- > data User = User { userId :: SObjId+-- > , userFirstName :: String+-- > , userLastName :: String+-- > }+--+-- This function generates:+--+-- > toBSON x = [ (u "_id") := val (userId x)+-- > , (u "userFirstName") := val (userFirstName x)+-- > , (u "userLastName") := val (userLastName x)+-- > ]+--+-- The "_id" is created only if userId is not 'noSObjId'.+-- +funD_toBSON :: Name -- ^ toSBSON Name+ -> [Name] -- ^ List of field Names+ -> Name -- ^ SObjId Name+ -> Q Dec -- ^ toBSON declaration+funD_toBSON toBSONName fieldNames sObjName = do+ x <- newName "x"+ toBSONBody <- NormalB <$> (gen_toBSON (varE x) fieldNames)+ let toBSONClause = Clause [VarP x] (toBSONBody) []+ return (FunD toBSONName [toBSONClause])+ where gen_toBSON _ [] = [| [] |]+ gen_toBSON x (f:fs) =+ let l = nameBase f + i = nameBase sObjName+ v = appE (varE f) x+ in if l /= i+ then [| ((u l) := val $v) : $(gen_toBSON x fs) |]+ else [| let y = ((u "_id") := val (unSObjId $v))+ ys = $(gen_toBSON x fs)+ in if isNoSObjId $v+ then ys+ else y : ys+ |]++-- | Generate the declaration for 'collection'+funD_collection :: Name -- ^ collection Name+ -> Name -- ^ Name of type constructor+ -> Q Dec -- ^ collection delclaration+funD_collection collectionName conName = do+ let n = nameBase conName+ d <- [d| collectionName _ = (u n) |]+ let [FunD _ cs] = d+ return (FunD collectionName cs)++funD_fromBSON :: Name -- ^ fromSBSON Name+ -> Name -- ^ Name of type constructor+ -> [Name] -- ^ List of field Names+ -> Name -- ^ SObjId name+ -> Q Dec -- ^ fromBSON declaration+funD_fromBSON fromBSONName conName fieldNames sObjName = do+ doc <- newName "doc"+ fromBSONBody <- NormalB <$>+ (gen_fromBSON conName fieldNames (varE doc) [] sObjName)+ let fromBSONClause = Clause [VarP doc] (fromBSONBody) []+ return (FunD fromBSONName [fromBSONClause])++-- | This function generates the body for the 'fromBSON' function+-- Suppose we have+--+-- > data User = User { userId :: SObjId+-- > , userFirstName :: String+-- > , userLastName :: String+-- > }+--+-- Given the constructor name (@User@), field names, a document+-- expression (e.g., @doc@), and empty accumulator, this function generates:+--+-- > fromBSON doc = lookup (u "_id") doc >>= \val_1 ->+-- > lookup (u "userFirstName") doc >>= \val_2 ->+-- > lookup (u "userLastName") doc >>= \val_3 ->+-- > return User { userId = val_1+-- > , userFirstName = val_2+-- > , userLastname = val_3+-- > }+--+--++-- | BSON's lookup with Maybe as underlying monad.+lookup_m :: Val v => Label -> Document -> Maybe v+lookup_m = BSON.lookup++-- | Lookup _id. If not found, do not fail. Rather return 'noSObjId'.+lookup_id :: Document -> Maybe SObjId+lookup_id d = Just (SObjId (lookup_m (u "_id") d :: Maybe ObjectId))+++gen_fromBSON :: Name -- ^ Constructor name+ -> [Name] -- ^ Field names+ -> Q Exp -- ^ Document expression+ -> [(Name, Name)] -- ^ Record field name, variable name pairs+ -> Name -- ^ SObjId name+ -> Q Exp -- ^ Record with fields set+gen_fromBSON conName [] _ vals _ = do+ (AppE ret _ ) <- [| return () |]+ let fExp = reverse $ map (\(l,v) -> (l, VarE v)) vals+ return (AppE ret (RecConE conName fExp))++gen_fromBSON conName (l:ls) doc vals sObjName =+ let lbl = nameBase l+ in if lbl == (nameBase sObjName)+ then [| lookup_id $doc >>= \v ->+ $(gen_fromBSON conName ls doc ((l,'v):vals) sObjName) |]+ else [| lookup_m (u lbl) $doc >>= \v ->+ $(gen_fromBSON conName ls doc ((l,'v):vals) sObjName) |]++-- | Given name of type, generate instance for BSON's @Val@ class.+gen_ValInstance :: Name -> Q Dec+gen_ValInstance t = do+ let valE = varE 'val+ [InstanceD valCtx (AppT valCType _) decs] <-+ [d| instance Val T1 where+ val d = $valE (toBSON d)+ cast' v = case v of+ (Doc d) -> fromBSON d + _ -> error "Only Doc supported"+ |]+ let decs' = (fixNames 'cast') <$> ((fixNames 'val) <$> decs)+ return (InstanceD valCtx (AppT valCType (ConT t)) decs') + where fixNames aN (FunD n cs) | (nameBase aN)+ `isPrefixOf` (nameBase n) = FunD aN cs+ fixNames _ x = x ++-- | Given name of type, and fields, generate new type corrsponding to+-- each field and make them instances of @Selectable@.+-- Suppose we have+--+-- > data User = User { userId :: SObjId+-- > , userFirstName :: String+-- > , userLastName :: String+-- > }+--+-- This fucntion generates the following types and instances:+--+-- > data UserId = UserId deriving (Show, Eq)+-- > instance Selectable User UserId SObjId where s _ _ = "_id"+-- > +-- > data FirstName = FirstName deriving (Show, Eq)+-- > instance Selectable User FirstName String where s _ _ = "firstName"+-- > +-- > data LastName = LastName deriving (Show, Eq)+-- > instance Selectable User LastName String where s _ _ = "lastName"+-- +genSelectable :: Name -> [VarStrictType] -> Q [Dec]+genSelectable conName vs = concat <$> (mapM (genSelectable' conName) vs)++-- | Given name of type, and field, generate new type corrsponding to+-- the field and make it an instance of @Selectable@.+genSelectable' :: Name -> VarStrictType -> Q [Dec]+genSelectable' conName (n,_,t) = do+ let bn = mkName . cap $ nameBase n+ sName = mkName "s"+ -- New type for field:+ [DataD _ _ _ _ derivs] <- [d| data Constr = Constr deriving (Eq, Show) |]+ let dataType = DataD [] bn [] [NormalC bn []] derivs+ -- Instance of Selectable:+ [InstanceD selCtx (AppT (AppT (AppT selT _) _) _)+ [FunD _ [Clause pats (NormalB (AppE varE_u _)) []]]]+ <- [d| instance Selectable T1 T2 T3 where+ s _ _ = (u "")+ |]+ let lit = LitE . StringL $ if is_id t then "_id" else nameBase n+ selInstance = + InstanceD selCtx (AppT (AppT (AppT selT (ConT conName)) (ConT bn)) t)+ [FunD sName+ [Clause pats+ (NormalB (AppE varE_u lit)) []+ ]+ ]+ --+ return [dataType, selInstance]+ where cap (c:cs) = toUpper c : cs+ cap x = x+ is_id (ConT c) = (c == ''SObjId)+ is_id _ = error "Invalid usage of is_id_, expecting ConT"++
+ Database/MongoDB/Structured/Query.hs view
@@ -0,0 +1,372 @@+{-| This module exports several classes and combinators that operated on+ 'Structured' types. Specifically, we provide the structured versions+ of @mongoDB@''s combinators, including structured query creation.+-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+module Database.MongoDB.Structured.Query (+ -- * Insert+ insert, insert_+ , insertMany, insertMany_+ , insertAll, insertAll_+ -- * Update+ , save+ -- * Delete+ , delete, deleteOne+ -- * Order+ , asc+ , desc+ -- * Query+ , StructuredQuery+ , limit+ , skip+ , sort+ , find+ , findOne+ , fetch+ , count+ -- * Structured selections/queries+ , StructuredSelection+ , StructuredSelect(select)+ , Selectable(..)+ , (.!)+ , QueryExp+ , (.*)+ , (.==), (./=), (.<), (.<=), (.>), (.>=)+ , (.&&), (.||), not_+ -- * Cursor+ , StructuredCursor+ , closeCursor, isCursorClosed+ , nextBatch, next, nextN, rest+ -- * Rexports+ , module Database.MongoDB.Query+ , Value+ ) where++import qualified Database.MongoDB.Query as M+import Database.MongoDB.Query (Action+ , access+ , Failure(..)+ , ErrorCode+ , AccessMode(..)+ , GetLastError+ , master+ , slaveOk+ , accessMode+ , MonadDB(..)+ , Database+ , allDatabases+ , useDb+ , thisDatabase+ , Username+ , Password+ , auth)+import Database.MongoDB.Structured.Types+import Database.MongoDB.Internal.Util+import Data.Bson+import Data.List (sortBy, groupBy)+import Data.Functor+import Data.Word+import Data.CompactString.UTF8 (intercalate)+import Control.Monad+import Control.Monad.MVar+import Control.Monad.IO.Class+++--+-- Insert+--++-- | Inserts document to its corresponding collection and return+-- the \"_id\" value.+insert :: (MonadIO' m, Structured a) => a -> Action m Value+insert x = M.insert (collection x) (toBSON x)++-- | Same as 'insert' but discarding result.+insert_ :: (MonadIO' m, Structured a) => a -> Action m ()+insert_ x = insert x >> return ()++-- | Inserts documents to their corresponding collection and return+-- their \"_id\" values.+insertMany :: (MonadIO' m, Structured a) => [a] -> Action m [Value]+insertMany = insertManyOrAll (M.insertMany)++-- | Same as 'insertMany' but discarding result.+insertMany_ :: (MonadIO' m, Structured a) => [a] -> Action m ()+insertMany_ ss = insertMany ss >> return ()++-- | Inserts documents to their corresponding collection and return+-- their \"_id\" values. Unlike 'insertMany', this function keeps+-- inserting remaining documents even if an error occurs.+insertAll :: (MonadIO' m, Structured a) => [a] -> Action m [Value]+insertAll = insertManyOrAll (M.insertAll)++-- | Same as 'insertAll' but discarding result.+insertAll_ :: (MonadIO' m, Structured a) => [a] -> Action m ()+insertAll_ ss = insertAll ss >> return ()++-- | Helper function that carries out the hard work for 'insertMany'+-- and 'insertAll'.+insertManyOrAll :: (MonadIO' m, Structured a) =>+ (M.Collection -> [Document] -> Action m [Value]) -> [a] -> Action m [Value]+insertManyOrAll insertFunc ss = do+ let docs = map (\x -> (collection x, toBSON x)) ss+ gdocs = (groupBy (\(a,_) (b,_) -> a == b))+ . (sortBy (\(a,_) (b,_) -> compare a b)) $ docs+ concat <$> (forM gdocs $ \ds ->+ if (null ds)+ then return []+ else insertFunc (fst . head $ ds) (map snd ds)+ )++--+-- Update+--++-- | Save document to collection. If the 'SObjId' field is set then+-- the document is updated, otherwise we perform an insert.+save :: (MonadIO' m, Structured a) => a -> Action m ()+save x = M.save (collection x) (toBSON x)+++--+-- Delete+--++-- | Delete all documents that match the selection/query.+delete :: MonadIO m => StructuredSelection -> Action m ()+delete = M.delete . unStructuredSelection ++-- | Delete the first documents that match the selection/query.+deleteOne :: MonadIO m => StructuredSelection -> Action m ()+deleteOne = M.deleteOne . unStructuredSelection +++--+-- Query+--++-- | Find documents satisfying query+find :: (MonadControlIO m, Functor m)+ => StructuredQuery -> Action m StructuredCursor+find q = StructuredCursor <$> (M.find . unStructuredQuery $ q)++-- | Find documents satisfying query+findOne :: (MonadIO m, Structured a)+ => StructuredQuery -> Action m (Maybe a)+findOne q = do + res <- M.findOne . unStructuredQuery $ q+ return $ res >>= fromBSON++-- | Same as 'findOne' but throws 'DocNotFound' if none match.+fetch :: (MonadIO m, Functor m, Structured a)+ => StructuredQuery -> Action m (Maybe a)+fetch q = fromBSON <$> (M.fetch . unStructuredQuery $ q)++-- | Count number of documents satisfying query.+count :: (MonadIO' m) => StructuredQuery -> Action m Int+count = M.count . unStructuredQuery+++--+--+--++-- | Wrapper for @mongoDB@'s @Cursor@.+newtype StructuredCursor = StructuredCursor { unStructuredCursor :: M.Cursor }++-- | Return next batch of structured documents.+nextBatch :: (Structured a, MonadControlIO m, Functor m)+ => StructuredCursor -> Action m [Maybe a]+nextBatch c = (map fromBSON) <$> M.nextBatch (unStructuredCursor c)++-- | Return next structured document. If failed return 'Left',+-- otherwise 'Right' of the deserialized result.+next :: (Structured a, MonadControlIO m)+ => StructuredCursor -> Action m (Either () (Maybe a))+next c = do+ res <- M.next (unStructuredCursor c)+ case res of+ Nothing -> return (Left ())+ Just r -> return (Right $ fromBSON r)++-- | Return up to next @N@ documents.+nextN :: (Structured a, MonadControlIO m, Functor m)+ => Int -> StructuredCursor -> Action m [Maybe a]+nextN n c = (map fromBSON) <$> M.nextN n (unStructuredCursor c)+++-- | Return the remaining documents in query result.+rest :: (Structured a, MonadControlIO m, Functor m)+ => StructuredCursor -> Action m [Maybe a]+rest c = (map fromBSON) <$> M.rest (unStructuredCursor c)++-- | Close the cursor.+closeCursor :: MonadControlIO m => StructuredCursor -> Action m ()+closeCursor = M.closeCursor . unStructuredCursor++-- | Check if the cursor is closed.+isCursorClosed :: MonadIO m => StructuredCursor -> Action m Bool+isCursorClosed = M.isCursorClosed . unStructuredCursor++++--+-- Structured selections/queries+--++-- | Wrapper for @mongoDB@'s @Selection@ type.+newtype StructuredSelection =+ StructuredSelection { unStructuredSelection :: M.Selection }+ deriving(Eq, Show)++-- | Wrapper for @mongoDB@'s @Query@ type.+data StructuredQuery = StructuredQuery+ { selection :: StructuredSelection+ -- ^ Actual query.+ , skip :: Word32 + -- ^ Number of matching objects to skip+ -- (default: 0).+ , limit :: Word32+ -- ^ Maximum number of objects to return+ -- (default: 0, no limit).+ , sort :: [OrderExp]+ -- ^ Sortresult by this order.+ }+ deriving(Eq, Show)+++-- | Analog to @mongoDB@'s @Select@ class+class StructuredSelect aQorS where+ -- | Create a selection or query from an expression+ select :: Structured a => QueryExp a -> aQorS++instance StructuredSelect StructuredSelection where+ select = StructuredSelection . expToSelection++instance StructuredSelect StructuredQuery where+ select x = StructuredQuery (StructuredSelection $ expToSelection x)+ 0 0 ([])++unStructuredQuery :: StructuredQuery -> M.Query+unStructuredQuery sq = M.Query [] -- options+ (unStructuredSelection $ selection sq)+ [] -- project+ (skip sq) -- skip+ (limit sq) -- limit+ (expToOrder $ sort sq) -- sort+ False 0 []++-- | Class defining a selectable type. Type 'a' corresponds to the+-- record type, 'f' corresponds to the field or facet, and 't'+-- corresponds to the field/facet type.+class Val t => Selectable a f t | f -> a, f -> t where+ -- | Given facet, return the BSON field name+ s :: f -> t -> Label++-- | Nested fields (used for extracting the names of fields in a+-- nested record). +data Nested f f' = Nested Label++-- | Combining two field names to create a 'Nested' type.+(.!) :: (Selectable r f t, Selectable t f' t') => f -> f' -> Nested f f'+(.!) f f' = Nested $ intercalate (u ".") [(s f undefined), (s f' undefined)]++instance (Selectable r f t, Selectable t f' t') =>+ Selectable r (Nested f f') t' where+ s (Nested l) _ = l++-- | A query expression.+data QueryExp a = StarExp+ | EqExp !Label !Value+ | LBinExp !UString !Label !Value+ | AndExp (QueryExp a) (QueryExp a) + | OrExp (QueryExp a) (QueryExp a) + | NotExp (QueryExp a)+ deriving (Eq, Show)++infix 9 .! +infix 4 .==, ./=, .<, .<=, .>, .>=+infixr 3 .&&+infixr 2 .||++-- | Combinator for @==@+(.*) :: (Structured a) => QueryExp a+(.*) = StarExp++-- | Combinator for @==@+(.==) :: (Val t, Selectable a f t) => f -> t -> QueryExp a+(.==) f v = EqExp (s f v) (val v)++-- | Combinator for @$ne@+(./=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a+(./=) f v = LBinExp (u "$ne") (s f v) (val v)++-- | Combinator for @<@+(.< ) :: (Val t, Selectable a f t) => f -> t -> QueryExp a+(.< ) f v = LBinExp (u "$lt") (s f v) (val v)++-- | Combinator for @<=@+(.<=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a+(.<=) f v = LBinExp (u "$lte") (s f v) (val v)++-- | Combinator for @>@+(.> ) :: (Val t, Selectable a f t) => f -> t -> QueryExp a+(.> ) f v = LBinExp (u "$gt") (s f v) (val v)++-- | Combinator for @>=@+(.>=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a+(.>=) f v = LBinExp (u "$gte") (s f v) (val v)++-- | Combinator for @$and@+(.&&) :: QueryExp a -> QueryExp a -> QueryExp a+(.&&) = AndExp++-- | Combinator for @$or@+(.||) :: QueryExp a -> QueryExp a -> QueryExp a+(.||) = OrExp++-- | Combinator for @$not@+not_ :: QueryExp a -> QueryExp a+not_ = NotExp++-- | Convert a query expression to a 'Selector'.+expToSelector :: Structured a => QueryExp a -> M.Selector+expToSelector (StarExp) = [ ]+expToSelector (EqExp l v) = [ l := v ]+expToSelector (LBinExp op l v) = [ l =: [ op := v ]]+expToSelector (AndExp e1 e2) = [ (u "$and") =: [expToSelector e1+ , expToSelector e2] ]+expToSelector (OrExp e1 e2) = [ (u "$or") =: [expToSelector e1+ , expToSelector e2] ]+expToSelector (NotExp e) = [ (u "$not") =: expToSelector e]++-- | Convert query expression to 'Selection'.+expToSelection :: Structured a => QueryExp a -> M.Selection+expToSelection e = M.Select { M.selector = (expToSelector e)+ , M.coll = (collection . c $ e) }+ where c :: Structured a => QueryExp a -> a+ c _ = undefined++-- | An ordering expression+data OrderExp = Desc Label+ | Asc Label+ deriving(Eq, Show)++-- | Sort by field, ascending+asc :: Selectable a f t => f -> OrderExp+asc f = Asc (s f undefined)++-- | Sort by field, descending+desc :: Selectable a f t => f -> OrderExp+desc f = Desc (s f undefined)++-- | Convert a list of @OrderExp@ to a @mongoDB@ @Order@+expToOrder :: [OrderExp] -> M.Order+expToOrder exps = map _expToLabel exps+ where _expToLabel (Desc fieldName) = fieldName := val (-1 :: Int)+ _expToLabel (Asc fieldName) = fieldName := val (1 :: Int)+
+ Database/MongoDB/Structured/Types.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | This module exports a 'Structued' type class which can be used to+-- convert Haskel \"record types\" to @BSON@ objects and vice versa.+-- As a Mongo document has an \"_id\" field, we impose the requirement+-- a record type have a field whose type is 'SObjId' (corresponding to+-- \"_id\").+module Database.MongoDB.Structured.Types ( Structured(..)+ -- * Structured \"_id\"+ , SObjId(..)+ , noSObjId, isNoSObjId+ , toSObjId, unSObjId+ ) where+import Database.MongoDB.Query (Collection)+import Data.Bson+import Data.Typeable++-- | Structured class used to convert between a Haskell record type+-- and BSON document.+class Structured a where+ collection :: a -> Collection -- ^ Collection name is then name of type+ toBSON :: a -> Document -- ^ Convert record to a BSON object+ fromBSON :: Document -> Maybe a -- ^ Convert BSON object to record++-- | Type corresponding to the \"_id\" field of a document in a+-- structured object.+newtype SObjId = SObjId (Maybe ObjectId)+ deriving(Show, Read, Eq, Ord, Typeable, Val)++-- | The \"_id\" field is unset.+noSObjId :: SObjId+noSObjId = SObjId Nothing++-- | Check if the \"_id\" field is unset.+isNoSObjId :: SObjId -> Bool+isNoSObjId = (==) noSObjId++-- | Get the \"_id\" field (assumes that it is set0.+unSObjId :: SObjId -> ObjectId+unSObjId (SObjId (Just x)) = x+unSObjId _ = error "invalid use"++-- | Set the \"_id\" field.+toSObjId :: ObjectId -> SObjId+toSObjId = SObjId . Just
+ LICENSE view
@@ -0,0 +1,17 @@+This program is free software; you can redistribute it and/or+modify it under the terms of the GNU General Public License as+published by the Free Software Foundation; either version 2, or (at+your option) any later version.++This program is distributed in the hope that it will be useful, but+WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+General Public License for more details.++You can obtain copies of permitted licenses from these URLs:++ http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt+ http://www.gnu.org/licenses/gpl-3.0.txt++or by writing to the Free Software Foundation, Inc., 59 Temple Place,+Suite 330, Boston, MA 02111-1307 USA
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main :: IO ()+main = defaultMain
+ examples/mongoExample.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+import Database.MongoDB.Structured+import Database.MongoDB.Structured.Deriving.TH+import Control.Monad.Trans (liftIO)+import Data.Typeable+import Control.Monad (mapM_)+import Control.Monad.IO.Class+import Data.Maybe (isJust, fromJust)++data Address = Address { addrId :: SObjId+ , city :: String+ , state :: String+ } deriving (Show, Eq, Typeable)+$(deriveStructured ''Address)++data Team = Team { teamId :: SObjId+ , name :: String+ , home :: Address+ , league :: String+ } deriving (Show, Eq, Typeable)+$(deriveStructured ''Team)++main = do+ pipe <- runIOE $ connect (host "127.0.0.1")+ e <- access pipe master "baseball" run+ close pipe+ print e++run = do+ clearTeams+ insertTeams+ allTeams >>= printDocs "All Teams"+ nationalLeagueTeams >>= printDocs "National League Teams"+ newYorkTeams >>= printDocs "New York Teams"++-- Delete all teams:+clearTeams :: Action IO ()+clearTeams = delete (select ( (.*) :: QueryExp Team))++insertTeams :: Action IO [Value]+insertTeams = insertMany [+ Team { teamId = noSObjId+ , name = "Yankees"+ , home = Address { addrId = noSObjId+ , city = "New York"+ , state = "NY"+ }+ , league = "American"}+ , Team { teamId = noSObjId+ , name = "Mets"+ , home = Address { addrId = noSObjId+ , city = "New York"+ , state = "NY"+ }+ , league = "National"}+ , Team { teamId = noSObjId+ , name = "Phillies"+ , home = Address { addrId = noSObjId+ , city = "Philadelphia"+ , state = "PA"+ }+ , league = "National"}+ , Team { teamId = noSObjId+ , name = "Red Sox"+ , home = Address { addrId = noSObjId+ , city = "Boston"+ , state = "MA"+ }+ , league = "National"}+ ]++allTeams :: Action IO [Maybe Team]+allTeams = let query = (select ((.*) :: QueryExp Team))+ { sort = [asc (Home .! City)]}+ in find query >>= rest+ +nationalLeagueTeams :: Action IO [Maybe Team]+nationalLeagueTeams = rest =<< find (select (League .== "National"))++newYorkTeams :: Action IO [Maybe Team]+newYorkTeams = rest =<< find (select (Home .! State .== "NY"))++printDocs :: MonadIO m => String -> [Maybe Team] -> m ()+printDocs title teams' = liftIO $ do+ let teams = (map fromJust) . filter (isJust) $ teams'+ putStrLn title + mapM_ (putStrLn . show) teams+
+ examples/simple.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UndecidableInstances #-}+import Data.UString hiding (find, sort, putStrLn)+import Database.MongoDB.Connection+import Data.Maybe (fromJust)+import Control.Monad (forM_)+import Control.Monad.Trans (liftIO)++import Data.Typeable+import Data.Bson+import Database.MongoDB.Structured+import Database.MongoDB.Structured.Deriving.TH+import Database.MongoDB.Structured.Query+++data Address = Address { addrId :: SObjId+ , streetNr :: Int+ , streetName :: String+ } deriving (Show, Read, Eq, Ord, Typeable)+$(deriveStructured ''Address)++data User = User { userId :: SObjId+ , firstName :: String+ , lastName :: String+ , favNr :: Int+ , addr :: Address+ } deriving(Show, Read, Eq, Ord, Typeable)+$(deriveStructured ''User)++insertUsers = insertMany + [ User { userId = noSObjId+ , firstName = "deian"+ , lastName = "stefan"+ , favNr = 3+ , addr = Address { addrId = noSObjId+ , streetNr = 123+ , streetName = "Mission" }+ }+ + , User { userId = noSObjId+ , firstName = "amit" + , lastName = "levy"+ , favNr = 42 + , addr = Address { addrId = noSObjId+ , streetNr = 42+ , streetName = "Market" }+ }+ + , User { userId = noSObjId+ , firstName = "david"+ , lastName = "mazieres"+ , favNr = 1337 + , addr = Address { addrId = noSObjId+ , streetNr = 821+ , streetName = "Valencia" }+ }+ ]++run = do+ delete (select ( (.*) :: QueryExp User))+ insertUsers+ let query = (select (Addr .! StreetNr .== 123 .|| FavNr .>= 3))+ { limit = 2+ , sort = [asc FirstName]+ , skip = 0 }+ liftIO $ print query+ users <- find query >>= rest+ liftIO $ printFunc users+ where printFunc users = forM_ users $ \u ->+ putStrLn . show $ (fromJust $ u :: User)++main = do+ pipe <- runIOE $ connect (host "127.0.0.1")+ e <- access pipe master "auth" run+ close pipe+ print e+
+ structured-mongoDB.cabal view
@@ -0,0 +1,43 @@+Name: structured-mongoDB+Version: 0.1+build-type: Simple+License: GPL+License-File: LICENSE+Author: HAILS team+Maintainer: Amit Levy <alevy at stanford dot edu>, Deian Stefan <deian at cs dot stanford dot edu>+Stability: experimental+Synopsis: Structured MongoDB interface+Category: Database+Cabal-Version: >= 1.6++Extra-source-files:+ examples/simple.hs+ examples/mongoExample.hs++Description:+ This module exports a structured type-safe interface to MongoDB.++Source-repository head+ Type: git+ Location: http://www.scs.stanford.edu/~deian/structured-mongoDB.git++Library+ Build-Depends: base >= 4 && < 5,+ array >= 0.2 && < 1,+ bytestring >= 0.9 && < 1,+ containers >= 0.2 && < 1,+ mtl >= 1.1.0.2 && < 3,+ transformers >= 0.2.2 && < 0.3,+ old-time >= 1 && < 2,+ mongoDB >= 1.1.1 && <2,+ bson >= 0.1.6 && <0.2,+ compact-string-fix >= 0.3.2 && < 0.4,+ template-haskell++ ghc-options: -Wall -fno-warn-orphans++ Exposed-modules:+ Database.MongoDB.Structured+ Database.MongoDB.Structured.Types+ Database.MongoDB.Structured.Query+ Database.MongoDB.Structured.Deriving.TH