diff --git a/Database/MongoDB/Structured.hs b/Database/MongoDB/Structured.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Structured.hs @@ -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 diff --git a/Database/MongoDB/Structured/Deriving/TH.hs b/Database/MongoDB/Structured/Deriving/TH.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Structured/Deriving/TH.hs @@ -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" + + diff --git a/Database/MongoDB/Structured/Query.hs b/Database/MongoDB/Structured/Query.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Structured/Query.hs @@ -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) + diff --git a/Database/MongoDB/Structured/Types.hs b/Database/MongoDB/Structured/Types.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Structured/Types.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/examples/mongoExample.hs b/examples/mongoExample.hs new file mode 100644 --- /dev/null +++ b/examples/mongoExample.hs @@ -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 + diff --git a/examples/simple.hs b/examples/simple.hs new file mode 100644 --- /dev/null +++ b/examples/simple.hs @@ -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 + diff --git a/structured-mongoDB.cabal b/structured-mongoDB.cabal new file mode 100644 --- /dev/null +++ b/structured-mongoDB.cabal @@ -0,0 +1,43 @@ +Name: structured-mongoDB +Version: 0.1 +build-type: Simple +License: GPL +License-File: LICENSE +Author: HAILS team +Maintainer: Amit Levy , Deian Stefan +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