├── Setup.hs
├── .gitignore
├── README.md
├── LICENSE
├── structured-mongoDB.cabal
├── Database
    └── MongoDB
    │   ├── Structured
    │       ├── Types.hs
    │       ├── Deriving
    │       │   ├── Generics.hs
    │       │   └── TH.hs
    │       └── Query.hs
    │   └── Structured.hs
└── examples
    ├── simple.hs
    └── mongoExample.hs


/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main :: IO ()
3 | main = defaultMain
4 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | *.hi
 2 | *.o
 3 | *.swp
 4 | *~
 5 | /tmp
 6 | /Setup
 7 | /dist
 8 | /doc
 9 | /ls
10 | /ps
11 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # structured-mongoDB: Structured MongoDB interface #
2 | 
3 | This package provides a structured, and well-typed interface to
4 | MongoDB, with mongoDB as the underlying target.
5 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | This program is free software; you can redistribute it and/or
 2 | modify it under the terms of the GNU General Public License as
 3 | published by the Free Software Foundation; either version 2, or (at
 4 | your option) any later version.
 5 | 
 6 | This program is distributed in the hope that it will be useful, but
 7 | WITHOUT ANY WARRANTY; without even the implied warranty of
 8 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 9 | General Public License for more details.
10 | 
11 | You can obtain copies of permitted licenses from these URLs:
12 | 
13 | 	http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt
14 | 	http://www.gnu.org/licenses/gpl-3.0.txt
15 | 
16 | or by writing to the Free Software Foundation, Inc., 59 Temple Place,
17 | Suite 330, Boston, MA 02111-1307 USA
18 | 


--------------------------------------------------------------------------------
/structured-mongoDB.cabal:
--------------------------------------------------------------------------------
 1 | Name:           structured-mongoDB
 2 | Version:        0.3
 3 | build-type:     Simple
 4 | License:        GPL
 5 | License-File:   LICENSE
 6 | Author:         HAILS team
 7 | Maintainer:	Amit Levy <alevy at stanford dot edu>, Deian Stefan  <deian at cs dot stanford dot edu>
 8 | Stability:      experimental
 9 | Synopsis:       Structured MongoDB interface
10 | Category:       Database
11 | Cabal-Version:  >= 1.6
12 | 
13 | Extra-source-files:
14 |     examples/simple.hs
15 |     examples/mongoExample.hs
16 | 
17 | Description:
18 |         This module exports a structured type-safe interface to MongoDB.
19 | 
20 | Source-repository head
21 |   Type:     git
22 |   Location: http://www.scs.stanford.edu/~deian/structured-mongoDB.git
23 | 
24 | Library
25 |   Build-Depends: base >= 4 && < 5,
26 |                  transformers-base >= 0.4.1 && < 0.5,
27 |                  monad-control >= 0.3.1 && < 0.4,
28 |                  array >= 0.2 && < 1,
29 |                  bytestring >= 0.9 && < 1,
30 |                  containers >= 0.2 && < 1,
31 |                  mtl >= 1.1.0.2 && < 3,
32 |                  transformers >= 0.2.2 && < 0.3,
33 |                  old-time >= 1 && < 2,
34 |                  mongoDB >= 1.2.0 && <2,
35 |                  bson >= 0.1.6 && <0.2,
36 |                  compact-string-fix >= 0.3.2 && < 0.4,
37 |                  template-haskell
38 | 
39 |   ghc-options: -Wall -fno-warn-orphans
40 | 
41 |   Exposed-modules:
42 |     Database.MongoDB.Structured
43 |     Database.MongoDB.Structured.Types
44 |     Database.MongoDB.Structured.Query
45 |     Database.MongoDB.Structured.Deriving.TH
46 | 


--------------------------------------------------------------------------------
/Database/MongoDB/Structured/Types.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 3 | {-# LANGUAGE DeriveDataTypeable #-}
 4 | #if __GLASGOW_HASKELL__ >= 702
 5 | {-# LANGUAGE Trustworthy #-}
 6 | #endif
 7 | -- | This module exports a 'Structued' type class which can be used to
 8 | -- convert Haskel \"record types\" to @BSON@ objects and vice versa.
 9 | -- As a Mongo document has an \"_id\" field, we impose the requirement
10 | -- a record type have a field whose type is 'SObjId' (corresponding to
11 | -- \"_id\").
12 | module Database.MongoDB.Structured.Types ( Structured(..)
13 |                                            -- * Structured \"_id\"
14 |                                           , SObjId(..)
15 |                                           , noSObjId, isNoSObjId
16 |                                           , toSObjId, unSObjId
17 |                                           ) where
18 | import Database.MongoDB.Query (Collection)
19 | import Data.Bson
20 | import Data.Typeable
21 | 
22 | -- | Structured class used to convert between a Haskell record type
23 | -- and BSON document.
24 | class Structured a where
25 |   collection :: a -> Collection     -- ^ Collection name is then name of type
26 |   toBSON     :: a -> Document       -- ^ Convert record to a BSON object
27 |   fromBSON   :: Document -> Maybe a -- ^ Convert BSON object to record
28 | 
29 | -- | Type corresponding to the \"_id\" field of a document in a
30 | -- structured object.
31 | newtype SObjId = SObjId (Maybe ObjectId)
32 |    deriving(Show, Read, Eq, Ord, Typeable, Val)
33 | 
34 | -- | The \"_id\" field is unset.
35 | noSObjId :: SObjId
36 | noSObjId = SObjId Nothing
37 | 
38 | -- | Check if the \"_id\" field is unset.
39 | isNoSObjId :: SObjId -> Bool
40 | isNoSObjId = (==) noSObjId
41 | 
42 | -- | Get the \"_id\" field (assumes that it is set0.
43 | unSObjId :: SObjId -> ObjectId
44 | unSObjId (SObjId (Just x)) = x
45 | unSObjId _ = error "invalid use"
46 | 
47 | -- | Set the \"_id\" field.
48 | toSObjId :: ObjectId -> SObjId
49 | toSObjId = SObjId . Just
50 | 


--------------------------------------------------------------------------------
/examples/simple.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TypeSynonymInstances #-}
 2 | {-# LANGUAGE FunctionalDependencies #-}
 3 | {-# LANGUAGE FlexibleInstances #-}
 4 | {-# LANGUAGE MultiParamTypeClasses #-}
 5 | {-# LANGUAGE OverloadedStrings #-}
 6 | {-# LANGUAGE TemplateHaskell #-}
 7 | {-# LANGUAGE DeriveDataTypeable #-}
 8 | {-# LANGUAGE UndecidableInstances #-}
 9 | import Data.UString hiding (find, sort, putStrLn)
10 | import Database.MongoDB.Connection
11 | import Data.Maybe (fromJust)
12 | import Control.Monad (forM_)
13 | import Control.Monad.Trans (liftIO)
14 | 
15 | import Data.Typeable
16 | import Data.Bson
17 | import Database.MongoDB.Structured
18 | import Database.MongoDB.Structured.Deriving.TH
19 | import Database.MongoDB.Structured.Query
20 | 
21 | 
22 | data Address = Address { addrId :: SObjId
23 |                        , streetNr :: Int
24 |                        , streetName :: String
25 |                        } deriving (Show, Read, Eq, Ord, Typeable)
26 | $(deriveStructured ''Address)
27 | 
28 | data User = User { userId    :: SObjId
29 |                  , firstName :: String
30 |                  , lastName  :: String
31 |                  , favNr     :: Int
32 |                  , addr      :: Address
33 |                  } deriving(Show, Read, Eq, Ord, Typeable)
34 | $(deriveStructured ''User)
35 | 
36 | insertUsers = insertMany 
37 |   [ User { userId = noSObjId
38 |          , firstName = "deian"
39 |          , lastName = "stefan"
40 |          , favNr = 3
41 |          , addr = Address { addrId = noSObjId
42 |                           , streetNr = 123
43 |                           , streetName = "Mission" }
44 |          }
45 |   
46 |   , User { userId = noSObjId
47 |          , firstName = "amit" 
48 |          , lastName = "levy"
49 |          , favNr = 42 
50 |          , addr = Address { addrId = noSObjId
51 |                           , streetNr = 42
52 |                           , streetName = "Market" }
53 |          }
54 |   
55 |   , User { userId = noSObjId
56 |          , firstName = "david"
57 |          , lastName = "mazieres"
58 |          , favNr = 1337 
59 |          , addr = Address { addrId = noSObjId
60 |                           , streetNr = 821
61 |                           , streetName = "Valencia" }
62 |          }
63 |   ]
64 | 
65 | run = do
66 |    delete (select ( (.*) :: QueryExp User))
67 |    insertUsers
68 |    let query = (select (Addr .! StreetNr .== 123 .|| FavNr .>= 3))
69 |                   { limit = 2
70 |                   , sort = [asc FirstName]
71 |                   , skip = 0 }
72 |    liftIO $ print query
73 |    users <- find query >>= rest
74 |    liftIO $ printFunc users
75 |     where printFunc users = forM_ users $ \u ->
76 |             putStrLn . show $ (fromJust $ u :: User)
77 | 
78 | main = do
79 |    pipe <- runIOE $ connect (host "127.0.0.1")
80 |    e <- access pipe master "auth" run
81 |    close pipe
82 |    print e
83 | 
84 | 


--------------------------------------------------------------------------------
/Database/MongoDB/Structured/Deriving/Generics.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TypeOperators #-}
 2 | {-# LANGUAGE DefaultSignatures #-}
 3 | {-# LANGUAGE FlexibleContexts #-}
 4 | {-# LANGUAGE FlexibleInstances #-}
 5 | {-# LANGUAGE StandaloneDeriving #-}
 6 | {-# LANGUAGE StandaloneDeriving #-}
 7 | {-# LANGUAGE DeriveGeneric #-}
 8 | {-# LANGUAGE DeriveDataTypeable #-}
 9 | 
10 | module Database.MongoDB.Structured.Deriving.Generics where
11 | 
12 | import Prelude 
13 | import qualified Prelude as Prelude
14 | import Data.Typeable
15 | import Data.Bson
16 | import Database.MongoDB.Query (Collection)
17 | import GHC.Generics
18 | 
19 | 
20 | 
21 | class Structured t where
22 |   collection :: t -> Collection -- ^ Collection name is then name of type
23 |   toBSON     :: t -> Document   -- ^ Convert record to a BSON object
24 | 
25 |   default collection :: (Generic t, Structured' (Rep t)) => t -> Collection
26 |   collection = collection' . from
27 |   default toBSON :: (Generic t, Structured' (Rep t)) => t -> Document
28 |   toBSON = toBSON' . from
29 | 
30 | 
31 | class Structured' f where
32 |   collection' :: f t -> Collection -- ^ Collection name is then name of type
33 |   toBSON'     :: f t -> Document   -- ^ Convert to BSON object
34 |   collection' = error "Invalid use of collection'"
35 | 
36 | -- Meta-data
37 | instance (Structured' p, Datatype d) => Structured' (D1 d p) where
38 |   collection' d = u $ datatypeName d
39 |   toBSON' d@(M1 x) = toBSON' x
40 | 
41 | instance (Structured' p, Constructor c) => Structured' (C1 c p) where
42 |   toBSON' (M1 x) = toBSON' x 
43 | 
44 | instance (Structured' p, Selector s) => Structured' (S1 s p) where
45 |   toBSON' s@(M1 x) = [(u $ selName s) := (value . head . toBSON' $ x)]
46 | 
47 | instance Val a => Structured' (K1 i a) where
48 |   toBSON' (K1 x) = [(u "INVALID") =: x]
49 | 
50 | -- Data
51 | instance Structured' U1 where
52 |   toBSON' U1 = []
53 | 
54 | instance (Structured' p1, Structured' p2) => Structured' (p1 :*: p2) where
55 |   toBSON' (x :*: y) = toBSON' x ++ toBSON' y
56 | 
57 | instance (Structured' p1, Structured' p2) => Structured' (p1 :+: p2) where
58 |   toBSON' = error "Sums are not supported"
59 | --
60 | 
61 | 
62 | data User = User { userId :: Int
63 |                  , userFirstName :: String
64 |                  , userLastName :: String
65 |                  }
66 |             deriving(Generic, Show, Read, Eq, Ord, Typeable)
67 | instance Structured User
68 | 
69 | instance Val User where
70 |   val u = val $ toBSON u
71 |   cast' = undefined
72 | 
73 | 
74 | data Profile = Profile { profileId   :: Int
75 |                        , profileName :: String
76 |                        , profileUser :: User
77 |                        }
78 |               deriving(Generic, Show, Read, Eq, Ord, Typeable)
79 | instance Structured Profile
80 | 
81 | doc :: Document
82 | doc = [ (u "profileId") =: (42 :: Int) , (u "profileName") =: "Woo" ]
83 | undoc :: Profile
84 | undoc = Profile { profileId = 42 , profileName = "Woo", profileUser = user1}
85 | 
86 | user1 :: User
87 | user1 = User { userId = 1337 , userFirstName = "w00t", userLastName = "pwn" }
88 | 
89 | main = do
90 |   putStrLn $ "Collection " ++ show (collection undoc)
91 |   putStrLn $ "BSON " ++ show (toBSON undoc)
92 | 
93 | {-
94 | NOTES:
95 | It's not clear that defining fromBSON ::  Document -> t is so straight
96 | forward.
97 | -}
98 | 


--------------------------------------------------------------------------------
/examples/mongoExample.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell #-}
 2 | {-# LANGUAGE TypeSynonymInstances #-}
 3 | {-# LANGUAGE MultiParamTypeClasses #-}
 4 | {-# LANGUAGE FlexibleInstances #-}
 5 | {-# LANGUAGE OverloadedStrings #-}
 6 | {-# LANGUAGE DeriveDataTypeable #-}
 7 | import Database.MongoDB.Structured
 8 | import Database.MongoDB.Structured.Deriving.TH
 9 | import Control.Monad.Trans (liftIO)
10 | import Data.Typeable
11 | import Control.Monad (mapM_)
12 | import Control.Monad.IO.Class
13 | import Data.Maybe (isJust, fromJust)
14 | 
15 | data Address = Address { addrId :: SObjId
16 |                        , city   :: String
17 |                        , state  :: String
18 |                        } deriving (Show, Eq, Typeable)
19 | $(deriveStructured ''Address)
20 | 
21 | data Team = Team { teamId :: SObjId
22 |                  , name   :: String
23 |                  , home   :: Address
24 |                  , league :: String
25 |                  } deriving (Show, Eq, Typeable)
26 | $(deriveStructured ''Team)
27 | 
28 | main = do
29 |    pipe <- runIOE $ connect (host "127.0.0.1")
30 |    e <- access pipe master "baseball" run
31 |    close pipe
32 |    print e
33 | 
34 | run = do
35 |    clearTeams
36 |    insertTeams
37 |    allTeams >>= printDocs "All Teams"
38 |    nationalLeagueTeams >>= printDocs "National League Teams"
39 |    newYorkTeams >>= printDocs "New York Teams"
40 | 
41 | -- Delete all teams:
42 | clearTeams :: Action IO ()
43 | clearTeams = delete (select ( (.*) :: QueryExp Team))
44 | 
45 | insertTeams :: Action IO [Value]
46 | insertTeams = insertMany [
47 |    Team { teamId = noSObjId
48 |         , name   = "Yankees"
49 |         , home   = Address { addrId = noSObjId
50 |                            , city  = "New York"
51 |                            , state = "NY"
52 |                            }
53 |         , league = "American"}
54 |   , Team { teamId = noSObjId
55 |          , name   = "Mets"
56 |          , home   = Address { addrId = noSObjId
57 |                             , city  = "New York"
58 |                             , state = "NY"
59 |                             }
60 |          , league = "National"}
61 |   , Team { teamId = noSObjId
62 |          , name   = "Phillies"
63 |          , home   = Address { addrId = noSObjId
64 |                             , city  = "Philadelphia"
65 |                             , state = "PA"
66 |                             }
67 |          , league = "National"}
68 |   , Team { teamId = noSObjId
69 |          , name   = "Red Sox"
70 |          , home   = Address { addrId = noSObjId
71 |                             , city  = "Boston"
72 |                             , state = "MA"
73 |                             }
74 |          , league = "National"}
75 |   ]
76 | 
77 | allTeams :: Action IO [Maybe Team]
78 | allTeams = let query = (select ((.*) :: QueryExp Team))
79 |                             { sort = [asc (Home .! City)]}
80 |            in find query >>= rest
81 |            
82 | nationalLeagueTeams :: Action IO [Maybe Team]
83 | nationalLeagueTeams = rest =<< find (select (League .== "National"))
84 | 
85 | newYorkTeams :: Action IO [Maybe Team]
86 | newYorkTeams = rest =<< find (select (Home .! State .== "NY"))
87 | 
88 | printDocs :: MonadIO m => String -> [Maybe Team] -> m ()
89 | printDocs title teams' = liftIO $ do
90 |   let teams = (map fromJust) . filter (isJust) $ teams'
91 |   putStrLn title 
92 |   mapM_ (putStrLn . show) teams
93 | 
94 | 


--------------------------------------------------------------------------------
/Database/MongoDB/Structured.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | #if __GLASGOW_HASKELL__ >= 702
  3 | {-# LANGUAGE Trustworthy #-}
  4 | #endif
  5 | -- | This module exports a /structued/ interface to MongoDB.
  6 | -- Specifically, Haskell record types are used (in place of BSON)
  7 | -- to represent documents which can be inserted and retrieved from
  8 | -- a MongoDB. Data types corresponding to fields of a document
  9 | -- are used in forming well-typed queries, as opposed to strings.
 10 | -- This module re-exports the "Database.MongoDB.Structured.Types"
 11 | -- module, which exports a 'Structured' type class --- this class is
 12 | -- used to convert Haskell record types to and from BSON documents.
 13 | -- The module "Database.MongoDB.Structured.Query" exports an
 14 | -- interface similar to @Database.MongoDB.Query@ which can be used to
 15 | -- insert, query, update, delete, etc. record types from a Mongo DB.
 16 | -- 
 17 | -- Though users may provide their own instances for 'Structured'
 18 | -- (and 'Selectable', used in composing well-typed queries), we
 19 | -- provide a Template Haskell function ('deriveStructured')
 20 | -- that can be used to automatically do this. See
 21 | -- "Database.MongoDB.Structured.Deriving.TH".
 22 | --
 23 | -- The example below shows how to use the structued MongoDB interface:
 24 | --
 25 | -- >    {-# LANGUAGE TemplateHaskell #-}
 26 | -- >    {-# LANGUAGE TypeSynonymInstances #-}
 27 | -- >    {-# LANGUAGE MultiParamTypeClasses #-}
 28 | -- >    {-# LANGUAGE FlexibleInstances #-}
 29 | -- >    {-# LANGUAGE OverloadedStrings #-}
 30 | -- >    {-# LANGUAGE DeriveDataTypeable #-}
 31 | -- >    import Database.MongoDB.Structured
 32 | -- >    import Database.MongoDB.Structured.Deriving.TH
 33 | -- >    import Control.Monad.Trans (liftIO)
 34 | -- >    import Data.Typeable
 35 | -- >    import Control.Monad (mapM_)
 36 | -- >    import Control.Monad.IO.Class
 37 | -- >    import Data.Bson (Value)
 38 | -- >    import Data.Maybe (isJust, fromJust)
 39 | -- >
 40 | -- >    data Address = Address { addrId :: SObjId
 41 | -- >                           , city   :: String
 42 | -- >                           , state  :: String
 43 | -- >                           } deriving (Show, Eq, Typeable)
 44 | -- >    $(deriveStructured ''Address)
 45 | -- >
 46 | -- >    data Team = Team { teamId :: SObjId
 47 | -- >                     , name   :: String
 48 | -- >                     , home   :: Address
 49 | -- >                     , league :: String
 50 | -- >                     } deriving (Show, Eq, Typeable)
 51 | -- >    $(deriveStructured ''Team)
 52 | -- >
 53 | -- >    main = do
 54 | -- >       pipe <- runIOE $ connect (host "127.0.0.1")
 55 | -- >       e <- access pipe master "baseball" run
 56 | -- >       close pipe
 57 | -- >       print e
 58 | -- >
 59 | -- >    run = do
 60 | -- >       clearTeams
 61 | -- >       insertTeams
 62 | -- >       allTeams >>= printDocs "All Teams"
 63 | -- >       nationalLeagueTeams >>= printDocs "National League Teams"
 64 | -- >       newYorkTeams >>= printDocs "New York Teams"
 65 | -- >
 66 | -- >    -- Delete all teams:
 67 | -- >    clearTeams :: Action IO ()
 68 | -- >    clearTeams = delete (select ( (.*) :: QueryExp Team))
 69 | -- >
 70 | -- >    insertTeams :: Action IO [Value]
 71 | -- >    insertTeams = insertMany [
 72 | -- >       Team { teamId = noSObjId
 73 | -- >            , name   = "Yankees"
 74 | -- >            , home   = Address { addrId = noSObjId
 75 | -- >                               , city  = "New York"
 76 | -- >                               , state = "NY"
 77 | -- >                               }
 78 | -- >            , league = "American"}
 79 | -- >      , Team { teamId = noSObjId
 80 | -- >             , name   = "Mets"
 81 | -- >             , home   = Address { addrId = noSObjId
 82 | -- >                                , city  = "New York"
 83 | -- >                                , state = "NY"
 84 | -- >                                }
 85 | -- >             , league = "National"}
 86 | -- >      , Team { teamId = noSObjId
 87 | -- >             , name   = "Phillies"
 88 | -- >             , home   = Address { addrId = noSObjId
 89 | -- >                                , city  = "Philadelphia"
 90 | -- >                                , state = "PA"
 91 | -- >                                }
 92 | -- >             , league = "National"}
 93 | -- >      , Team { teamId = noSObjId
 94 | -- >             , name   = "Red Sox"
 95 | -- >             , home   = Address { addrId = noSObjId
 96 | -- >                                , city  = "Boston"
 97 | -- >                                , state = "MA"
 98 | -- >                                }
 99 | -- >             , league = "National"}
100 | -- >      ]
101 | -- >
102 | -- >    allTeams :: Action IO [Maybe Team]
103 | -- >    allTeams = let query = (select ((.*) :: QueryExp Team))
104 | -- >                                { sort = [asc (Home .! City)]}
105 | -- >               in find query >>= rest
106 | -- >               
107 | -- >    nationalLeagueTeams :: Action IO [Maybe Team]
108 | -- >    nationalLeagueTeams = rest =<< find (select (League .== "National"))
109 | -- >
110 | -- >    newYorkTeams :: Action IO [Maybe Team]
111 | -- >    newYorkTeams = rest =<< find (select (Home .! State .== "NY"))
112 | -- >
113 | -- >    printDocs :: MonadIO m => String -> [Maybe Team] -> m ()
114 | -- >    printDocs title teams' = liftIO $ do
115 | -- >      let teams = (map fromJust) . filter (isJust) $ teams'
116 | -- >      putStrLn title 
117 | -- >      mapM_ (putStrLn . show) teams
118 | --
119 | module Database.MongoDB.Structured ( module Database.MongoDB.Structured.Types
120 |                                    , module Database.MongoDB.Connection
121 |                                    , module Database.MongoDB.Structured.Query
122 |                                    ) where
123 | 
124 | import Database.MongoDB.Structured.Types
125 | import Database.MongoDB.Connection
126 | import Database.MongoDB.Structured.Query
127 | 


--------------------------------------------------------------------------------
/Database/MongoDB/Structured/Deriving/TH.hs:
--------------------------------------------------------------------------------
  1 | -- | This module exports a 'Structued' type class which can be used to
  2 | -- convert from Haskel \"record types\" to @BSON@ objects and vice versa.
  3 | -- We use Templace Haskell to provide a function 'deriveStructured'
  4 | -- which can be used to automatically generate an instance of such
  5 | -- types for the 'Structured' and BSON's @Val@ classes.
  6 | --
  7 | -- For instance:
  8 | --
  9 | -- > data User = User { userId :: Int
 10 | -- >                  , userFirstName :: String
 11 | -- >                  , userLastName :: String
 12 | -- >                  }
 13 | -- >             deriving(Show, Read, Eq, Ord, Typeable)
 14 | -- > $(deriveStructured ''User)
 15 | -- > 
 16 | --
 17 | -- 'deriveStrctured' used used to create the following instance of 'Structured':
 18 | --
 19 | -- > instance Structured User where
 20 | -- >   toBSON x = [ (u "_id")           := val (userId x)
 21 | -- >              , (u "userFirstName") := val (userFirstName x)
 22 | -- >              , (u "userLastName")  := val (userLastName x)
 23 | -- >              ]
 24 | -- >   
 25 | -- >   fromBSON doc = lookup (u "_id")             doc >>= \val_1 ->
 26 | -- >                  lookup (u "userFirstName")   doc >>= \val_2 ->
 27 | -- >                  lookup (u "userLastName")    doc >>= \val_3 ->
 28 | -- >                  return User { userId        = val_1
 29 | -- >                              , userFirstName = val_2
 30 | -- >                              , userLastname  = val_3
 31 | -- >                              }
 32 | -- 
 33 | -- To allow for structured and well-typed queies, it also generates
 34 | -- types corresponding to each field (which are made an instance of
 35 | -- 'Selectable'). Specifically, for the above data type, it creates:
 36 | -- 
 37 | -- >  data UserId = UserId deriving (Show, Eq)
 38 | -- >  instance Selectable User UserId SObjId where s _ _ = "_id"
 39 | -- >  
 40 | -- >  data FirstName = FirstName deriving (Show, Eq)
 41 | -- >  instance Selectable User FirstName String where s _ _ = "firstName"
 42 | -- >  
 43 | -- >  data LastName = LastName deriving (Show, Eq)
 44 | -- >  instance Selectable User LastName String where s _ _ = "lastName"
 45 | --
 46 | {-# LANGUAGE MultiParamTypeClasses #-}
 47 | {-# LANGUAGE TemplateHaskell #-}
 48 | module Database.MongoDB.Structured.Deriving.TH ( deriveStructured ) where
 49 | 
 50 | import Database.MongoDB.Structured.Query
 51 | import Database.MongoDB.Structured
 52 | import Language.Haskell.TH
 53 | import Language.Haskell.TH.Syntax
 54 | import Data.Char (toUpper)
 55 | import Data.Bson
 56 | import qualified Data.Bson as BSON
 57 | import Data.Functor ((<$>))
 58 | import Data.List (isPrefixOf)
 59 | 
 60 | data T1 = T1
 61 | data T2 = T2
 62 | data T3 = T3
 63 | 
 64 | -- | This function generates 'Structured' and @Val@ instances for
 65 | -- record types.
 66 | deriveStructured :: Name -> Q [Dec]
 67 | deriveStructured t = do
 68 |   let className      = ''Structured
 69 |   let collectionName = 'collection
 70 |   let toBSONName     = 'toBSON
 71 |   let fromBSONName   = 'fromBSON
 72 | 
 73 |   -- Get record fields:
 74 |   TyConI (DataD _ _ _ (RecC conName fields:[]) _) <- getFields t
 75 |   let fieldNames = map first fields
 76 |       sObjIds = lookForSObjId fields
 77 | 
 78 |   guardSObjId sObjIds
 79 |   let sObjName = (first . head) sObjIds
 80 | 
 81 |   collectionFunD <- funD_collection collectionName conName
 82 |   toBSONFunD     <- funD_toBSON toBSONName fieldNames sObjName
 83 |   fromBSONFunD   <- funD_fromBSON fromBSONName conName fieldNames sObjName
 84 |   
 85 |   selTypesAndInst <- genSelectable t fields
 86 | 
 87 |   -- Generate Structured instance:
 88 |   let structuredInst = InstanceD [] (AppT (ConT className) (ConT t)) 
 89 |                          [ collectionFunD
 90 |                          , toBSONFunD
 91 |                          , fromBSONFunD ]
 92 |   -- Generate Val instance:
 93 |   valInst <- gen_ValInstance t
 94 | 
 95 |   return $ [structuredInst, valInst] ++ selTypesAndInst
 96 |     where getFields t1 = do
 97 |             r <- reify t1
 98 |             case r of
 99 |               TyConI (DataD _ _ _ (RecC _ _:[]) _) -> return ()
100 |               _ -> report True "Unsupported type. Can only derive for\
101 |                                \ single-constructor record types."
102 |             return r
103 |           lookForSObjId = filter f
104 |             where f (_,_,(ConT n)) = (n == ''SObjId)
105 |                   f _ = False
106 |           guardSObjId ids = if length ids /= 1
107 |                               then report True "Expecting 1 SObjId field."
108 |                               else return ()
109 |           first (a,_,_) = a
110 | 
111 | -- | Generate the declaration for 'toBSON'.
112 | --
113 | -- Suppose we have
114 | --
115 | -- >  data User = User { userId        :: SObjId
116 | -- >                   , userFirstName :: String
117 | -- >                   , userLastName  :: String
118 | -- >                   }
119 | --
120 | -- This function generates:
121 | --
122 | -- >  toBSON x = [ (u "_id")           := val (userId x)
123 | -- >             , (u "userFirstName") := val (userFirstName x)
124 | -- >             , (u "userLastName")  := val (userLastName x)
125 | -- >             ]
126 | --
127 | -- The "_id" is created only if userId is not 'noSObjId'.
128 | -- 
129 | funD_toBSON :: Name     -- ^ toSBSON Name
130 |             -> [Name]   -- ^ List of field Names
131 |             -> Name     -- ^ SObjId Name
132 |             -> Q Dec    -- ^ toBSON declaration
133 | funD_toBSON toBSONName fieldNames sObjName = do
134 |   x <- newName "x"
135 |   toBSONBody <- NormalB <$> (gen_toBSON (varE x) fieldNames)
136 |   let toBSONClause = Clause [VarP x] (toBSONBody) []
137 |   return (FunD toBSONName [toBSONClause])
138 |     where gen_toBSON _ []     = [| [] |]
139 |           gen_toBSON x (f:fs) =
140 |             let l = nameBase f 
141 |                 i = nameBase sObjName
142 |                 v = appE (varE f) x
143 |              in if l /= i
144 |                   then [| ((u l) := val $v) : $(gen_toBSON x fs) |]
145 |                   else [| let y  = ((u "_id") := val (unSObjId $v))
146 |                               ys = $(gen_toBSON x fs)
147 |                           in if isNoSObjId $v
148 |                                then ys
149 |                                else y : ys
150 |                        |]
151 | 
152 | -- | Generate the declaration for 'collection'
153 | funD_collection :: Name    -- ^ collection Name
154 |                 -> Name    -- ^ Name of type constructor
155 |                 -> Q Dec   -- ^ collection delclaration
156 | funD_collection collectionName conName = do
157 |   let n = nameBase conName
158 |   d <- [d| collectionName _ = (u n) |]
159 |   let [FunD _ cs] = d
160 |   return (FunD collectionName cs)
161 | 
162 | funD_fromBSON :: Name     -- ^ fromSBSON Name
163 |               -> Name     -- ^ Name of type constructor
164 |               -> [Name]   -- ^ List of field Names
165 |               -> Name     -- ^ SObjId name
166 |               -> Q Dec    -- ^ fromBSON declaration
167 | funD_fromBSON fromBSONName conName fieldNames sObjName = do
168 |   doc <- newName "doc"
169 |   fromBSONBody <- NormalB <$>
170 |                     (gen_fromBSON conName fieldNames (varE doc) [] sObjName)
171 |   let fromBSONClause = Clause [VarP doc] (fromBSONBody) []
172 |   return (FunD fromBSONName [fromBSONClause])
173 | 
174 | -- | This function generates the body for the 'fromBSON' function
175 | -- Suppose we have
176 | --
177 | -- >  data User = User { userId        :: SObjId
178 | -- >                   , userFirstName :: String
179 | -- >                   , userLastName  :: String
180 | -- >                   }
181 | --
182 | -- Given the constructor name (@User@), field names, a document
183 | -- expression (e.g., @doc@), and empty accumulator, this function generates:
184 | --
185 | -- >  fromBSON doc = lookup (u "_id")             doc >>= \val_1 ->
186 | -- >                 lookup (u "userFirstName")   doc >>= \val_2 ->
187 | -- >                 lookup (u "userLastName")    doc >>= \val_3 ->
188 | -- >                 return User { userId        = val_1
189 | -- >                             , userFirstName = val_2
190 | -- >                             , userLastname  = val_3
191 | -- >                             }
192 | --
193 | --
194 | 
195 | -- | BSON's lookup with Maybe as underlying monad.
196 | lookup_m :: Val v => Label -> Document -> Maybe v
197 | lookup_m = BSON.lookup
198 | 
199 | -- | Lookup _id. If not found, do not fail. Rather return 'noSObjId'.
200 | lookup_id :: Document -> Maybe SObjId
201 | lookup_id d = Just (SObjId (lookup_m (u "_id") d :: Maybe ObjectId))
202 | 
203 | 
204 | gen_fromBSON :: Name            -- ^ Constructor name
205 |              -> [Name]          -- ^ Field names
206 |              -> Q Exp           -- ^ Document expression
207 |              -> [(Name, Name)]  -- ^ Record field name, variable name pairs
208 |              -> Name            -- ^ SObjId name
209 |              -> Q Exp           -- ^ Record with fields set
210 | gen_fromBSON conName []     _   vals _ = do
211 |   (AppE ret _ )  <- [| return () |]
212 |   let fExp = reverse $ map (\(l,v) -> (l, VarE v)) vals
213 |   return (AppE ret (RecConE conName fExp))
214 | 
215 | gen_fromBSON conName (l:ls) doc vals sObjName =
216 |   let lbl = nameBase l
217 |   in if lbl == (nameBase sObjName)
218 |       then [| lookup_id $doc >>= \v ->
219 |               $(gen_fromBSON conName ls doc ((l,'v):vals) sObjName) |]
220 |       else [| lookup_m (u lbl) $doc >>= \v ->
221 |               $(gen_fromBSON conName ls doc ((l,'v):vals) sObjName) |]
222 | 
223 | -- | Given name of type, generate instance for BSON's @Val@ class.
224 | gen_ValInstance :: Name -> Q Dec
225 | gen_ValInstance t = do
226 |   let valE = varE 'val
227 |   [InstanceD valCtx (AppT valCType _) decs] <-
228 |              [d| instance Val T1 where
229 |                    val d = $valE (toBSON d)
230 |                    cast' v = case v of
231 |                                (Doc d) -> fromBSON d 
232 |                                _ -> error "Only Doc supported"
233 |              |]
234 |   let decs' = (fixNames 'cast') <$> ((fixNames 'val) <$> decs)
235 |   return (InstanceD valCtx (AppT valCType (ConT t)) decs') 
236 |     where fixNames aN (FunD n cs) | (nameBase aN)
237 |                                       `isPrefixOf` (nameBase n) = FunD aN cs
238 |           fixNames _  x = x 
239 | 
240 | -- | Given name of type, and fields, generate new type corrsponding to
241 | -- each field and make them instances of @Selectable@.
242 | -- Suppose we have
243 | --
244 | -- >  data User = User { userId        :: SObjId
245 | -- >                   , userFirstName :: String
246 | -- >                   , userLastName  :: String
247 | -- >                   }
248 | --
249 | -- This fucntion generates the following types and instances:
250 | --
251 | -- >  data UserId = UserId deriving (Show, Eq)
252 | -- >  instance Selectable User UserId SObjId where s _ _ = "_id"
253 | -- >  
254 | -- >  data FirstName = FirstName deriving (Show, Eq)
255 | -- >  instance Selectable User FirstName String where s _ _ = "firstName"
256 | -- >  
257 | -- >  data LastName = LastName deriving (Show, Eq)
258 | -- >  instance Selectable User LastName String where s _ _ = "lastName"
259 | -- 
260 | genSelectable :: Name -> [VarStrictType] -> Q [Dec]
261 | genSelectable conName vs = concat <$> (mapM (genSelectable' conName) vs)
262 | 
263 | -- | Given name of type, and field, generate new type corrsponding to
264 | -- the field and make it an instance of @Selectable@.
265 | genSelectable' :: Name -> VarStrictType -> Q [Dec]
266 | genSelectable' conName (n,_,t) = do
267 |   let bn = mkName . cap $ nameBase n
268 |       sName = mkName "s"
269 |   -- New type for field:
270 |   let dataType = DataD [] bn [] [NormalC bn []] [''Show, ''Eq]
271 |   -- Instance of Selectable:
272 |   [InstanceD selCtx (AppT (AppT (AppT selT _) _) _)
273 |                     [FunD _ [Clause pats (NormalB (AppE varE_u _)) []]]]
274 |      <-  [d| instance Selectable T1 T2 T3 where
275 |                s _ _ = (u "")
276 |          |]
277 |   let lit = LitE .  StringL $ if is_id t then "_id" else nameBase n
278 |       selInstance = 
279 |         InstanceD selCtx (AppT (AppT (AppT selT (ConT conName)) (ConT bn)) t)
280 |             [FunD sName
281 |                    [Clause pats
282 |                      (NormalB (AppE varE_u lit)) []
283 |                    ]
284 |             ]
285 |   --
286 |   return [dataType, selInstance]
287 |     where cap (c:cs) = toUpper c : cs
288 |           cap x = x
289 |           is_id (ConT c) = (c == ''SObjId)
290 |           is_id _        = error "Invalid usage of is_id_, expecting ConT"
291 | 
292 | 


--------------------------------------------------------------------------------
/Database/MongoDB/Structured/Query.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | #if __GLASGOW_HASKELL__ >= 702
  3 | {-# LANGUAGE Trustworthy #-}
  4 | #endif
  5 | {-| This module exports several classes and combinators that operated on
  6 |   'Structured' types. Specifically, we provide the structured versions
  7 |   of @mongoDB@''s combinators, including structured query creation.
  8 | -}
  9 | {-# LANGUAGE Rank2Types #-}
 10 | {-# LANGUAGE FunctionalDependencies #-}
 11 | {-# LANGUAGE FlexibleInstances #-}
 12 | {-# LANGUAGE FlexibleContexts #-}
 13 | {-# LANGUAGE MultiParamTypeClasses #-}
 14 | {-# LANGUAGE UndecidableInstances #-}
 15 | module Database.MongoDB.Structured.Query (
 16 |                                           -- * Insert
 17 |                                            insert, insert_
 18 |                                          , insertMany, insertMany_
 19 |                                          , insertAll, insertAll_
 20 |                                          -- * Update
 21 |                                          , save
 22 |                                          -- * Delete
 23 |                                          , delete, deleteOne
 24 |                                          -- * Order
 25 |                                          , asc
 26 |                                          , desc
 27 |                                          -- * Query
 28 |                                          , StructuredQuery
 29 |                                          , limit
 30 |                                          , skip
 31 |                                          , sort
 32 |                                          , find
 33 |                                          , findOne
 34 |                                          , fetch
 35 |                                          , count
 36 |                                          -- * Structured selections/queries
 37 |                                          , StructuredSelection
 38 |                                          , StructuredSelect(select)
 39 |                                          , Selectable(..)
 40 |                                          , (.!)
 41 |                                          , QueryExp
 42 |                                          , (.*)
 43 |                                          , (.==), (./=), (.<), (.<=), (.>), (.>=)
 44 |                                          , (.&&), (.||), not_
 45 |                                          -- * Cursor
 46 |                                          , StructuredCursor
 47 |                                          , closeCursor, isCursorClosed
 48 |                                          , nextBatch, next, nextN, rest
 49 |                                          -- * Rexports
 50 |                                          , module Database.MongoDB.Query
 51 |                                          , Value
 52 |                                          ) where
 53 | 
 54 | import qualified Database.MongoDB.Query as M
 55 | import Database.MongoDB.Query (Action
 56 |                               , access
 57 |                               , Failure(..)
 58 |                               , ErrorCode
 59 |                               , AccessMode(..)
 60 |                               , GetLastError
 61 |                               , master
 62 |                               , slaveOk
 63 |                               , accessMode
 64 |                               , MonadDB(..)
 65 |                               , Database
 66 |                               , allDatabases
 67 |                               , useDb
 68 |                               , thisDatabase
 69 |                               , Username
 70 |                               , Password
 71 |                               , auth)
 72 | import Database.MongoDB.Structured.Types
 73 | import Database.MongoDB.Internal.Util
 74 | import Data.Bson
 75 | import Data.Maybe (fromJust)
 76 | import Data.List (sortBy, groupBy)
 77 | import Data.Functor
 78 | import Data.Word
 79 | import Data.CompactString.UTF8 (intercalate)
 80 | import Control.Monad
 81 | import Control.Monad.IO.Class
 82 | import Control.Monad.Trans.Control
 83 | import Control.Monad.Base
 84 | 
 85 | 
 86 | --
 87 | -- Insert
 88 | --
 89 | 
 90 | -- | Inserts document to its corresponding collection and return
 91 | -- the \"_id\" value.
 92 | insert :: (MonadIO' m, Structured a) => a -> Action m Value
 93 | insert x = M.insert (collection x) (toBSON x)
 94 | 
 95 | -- | Same as 'insert' but discarding result.
 96 | insert_ :: (MonadIO' m, Structured a) => a -> Action m ()
 97 | insert_ x = insert x >> return ()
 98 | 
 99 | -- | Inserts documents to their corresponding collection and return
100 | -- their \"_id\" values.
101 | insertMany :: (MonadIO' m, Structured a) => [a] -> Action m [Value]
102 | insertMany = insertManyOrAll (M.insertMany)
103 | 
104 | -- | Same as 'insertMany' but discarding result.
105 | insertMany_ :: (MonadIO' m, Structured a) => [a] -> Action m ()
106 | insertMany_ ss = insertMany ss >> return ()
107 | 
108 | -- | Inserts documents to their corresponding collection and return
109 | -- their \"_id\" values. Unlike 'insertMany', this function keeps
110 | -- inserting remaining documents even if an error occurs.
111 | insertAll :: (MonadIO' m, Structured a) => [a] -> Action m [Value]
112 | insertAll = insertManyOrAll (M.insertAll)
113 | 
114 | -- | Same as 'insertAll' but discarding result.
115 | insertAll_ :: (MonadIO' m, Structured a) => [a] -> Action m ()
116 | insertAll_ ss = insertAll ss >> return ()
117 | 
118 | -- | Helper function that carries out the hard work for 'insertMany'
119 | -- and 'insertAll'.
120 | insertManyOrAll :: (MonadIO' m, Structured a) =>
121 |    (M.Collection -> [Document] -> Action m [Value]) -> [a] -> Action m [Value]
122 | insertManyOrAll insertFunc ss = do
123 |   let docs  = map (\x -> (collection x, toBSON x)) ss
124 |       gdocs = (groupBy (\(a,_) (b,_) -> a == b))
125 |               . (sortBy (\(a,_) (b,_) -> compare a b)) $ docs
126 |   concat <$> (forM gdocs $ \ds ->
127 |                 if (null ds)
128 |                   then return []
129 |                   else insertFunc (fst . head $ ds) (map snd ds)
130 |              )
131 | 
132 | --
133 | -- Update
134 | --
135 | 
136 | -- | Save document to collection. If the 'SObjId' field is set then
137 | -- the document is updated, otherwise we perform an insert.
138 | save :: (MonadIO' m, Structured a) => a -> Action m ()
139 | save x = M.save (collection x) (toBSON x)
140 | 
141 | 
142 | --
143 | -- Delete
144 | --
145 | 
146 | -- | Delete all documents that match the selection/query.
147 | delete :: MonadIO m => StructuredSelection -> Action m ()
148 | delete = M.delete . unStructuredSelection 
149 | 
150 | -- | Delete the first documents that match the selection/query.
151 | deleteOne :: MonadIO m => StructuredSelection -> Action m ()
152 | deleteOne = M.deleteOne . unStructuredSelection 
153 | 
154 | 
155 | --
156 | -- Query
157 | --
158 | 
159 | -- | Find documents satisfying query
160 | find :: (Functor m, MonadIO m, MonadBaseControl IO m)
161 |      => StructuredQuery -> Action m StructuredCursor
162 | find q = StructuredCursor <$> (M.find . unStructuredQuery $ q)
163 | 
164 | -- | Find documents satisfying query
165 | findOne :: (MonadIO m, Structured a)
166 |      => StructuredQuery -> Action m (Maybe a)
167 | findOne q = do 
168 |   res <- M.findOne . unStructuredQuery $ q
169 |   return $ res >>= fromBSON
170 | 
171 | -- | Same as 'findOne' but throws 'DocNotFound' if none match. Error
172 | -- is thrown if the document cannot e transformed.
173 | fetch :: (MonadIO m, Functor m, Structured a)
174 |      => StructuredQuery -> Action m a
175 | fetch q = (fromJust . fromBSON) <$> (M.fetch . unStructuredQuery $ q)
176 | 
177 | -- | Count number of documents satisfying query.
178 | count :: (MonadIO' m) => StructuredQuery -> Action m Int
179 | count = M.count . unStructuredQuery
180 | 
181 | 
182 | --
183 | --
184 | --
185 | 
186 | -- | Wrapper for @mongoDB@'s @Cursor@.
187 | newtype StructuredCursor = StructuredCursor { unStructuredCursor :: M.Cursor }
188 | 
189 | -- | Return next batch of structured documents.
190 | nextBatch :: (Structured a, Functor m, MonadIO m, MonadBaseControl IO m)
191 |           => StructuredCursor -> Action m [Maybe a]
192 | nextBatch c = (map fromBSON) <$> M.nextBatch (unStructuredCursor c)
193 | 
194 | -- | Return next structured document. If failed return 'Left',
195 | -- otherwise 'Right' of the deserialized result.
196 | next :: (Structured a, MonadIO m, MonadBaseControl IO m)
197 |      => StructuredCursor -> Action m (Either () (Maybe a))
198 | next c = do
199 |     res <- M.next (unStructuredCursor c)
200 |     case res of
201 |       Nothing -> return (Left ())
202 |       Just r  -> return (Right $ fromBSON r)
203 | 
204 | -- | Return up to next @N@ documents.
205 | nextN :: (Structured a, Functor m, MonadIO m, MonadBaseControl IO m)
206 |       => Int -> StructuredCursor -> Action m [Maybe a]
207 | nextN n c = (map fromBSON) <$> M.nextN n (unStructuredCursor c)
208 | 
209 | 
210 | -- | Return the remaining documents in query result.
211 | rest :: (Structured a, Functor m, MonadIO m, MonadBaseControl IO m) 
212 |      => StructuredCursor -> Action m [Maybe a]
213 | rest c = (map fromBSON) <$> M.rest (unStructuredCursor c)
214 | 
215 | -- | Close the cursor.
216 | closeCursor :: (MonadIO m, MonadBaseControl IO m) => StructuredCursor -> Action m ()
217 | closeCursor = M.closeCursor . unStructuredCursor
218 | 
219 | -- | Check if the cursor is closed.
220 | isCursorClosed :: (MonadIO m, MonadBase IO m) => StructuredCursor -> Action m Bool
221 | isCursorClosed = M.isCursorClosed . unStructuredCursor
222 | 
223 | 
224 | 
225 | --
226 | -- Structured selections/queries
227 | --
228 | 
229 | -- | Wrapper for @mongoDB@'s @Selection@ type.
230 | newtype StructuredSelection =
231 |   StructuredSelection { unStructuredSelection :: M.Selection }
232 |   deriving(Eq, Show)
233 | 
234 | -- | Wrapper for @mongoDB@'s @Query@ type.
235 | data StructuredQuery = StructuredQuery
236 |                         { selection :: StructuredSelection
237 |                         -- ^ Actual query.
238 |                         , skip      :: Word32 
239 |                         -- ^ Number of matching objects to skip
240 |                         -- (default: 0).
241 |                         , limit     :: Word32
242 |                         -- ^ Maximum number of objects to return
243 |                         -- (default: 0, no limit).
244 |                         , sort      :: [OrderExp]
245 |                         -- ^ Sortresult by this order.
246 |                         }
247 |   deriving(Eq, Show)
248 | 
249 | 
250 | -- | Analog to @mongoDB@'s @Select@ class
251 | class StructuredSelect aQorS where
252 |   -- | Create a selection or query from an expression
253 |   select :: Structured a => QueryExp a -> aQorS
254 | 
255 | instance StructuredSelect StructuredSelection where
256 |   select = StructuredSelection . expToSelection
257 | 
258 | instance StructuredSelect StructuredQuery where
259 |   select x = StructuredQuery (StructuredSelection $ expToSelection x)
260 |                               0 0 ([])
261 | 
262 | unStructuredQuery :: StructuredQuery -> M.Query
263 | unStructuredQuery sq = M.Query [] -- options
264 |                                (unStructuredSelection $ selection sq)
265 |                                [] -- project
266 |                                (skip sq) -- skip
267 |                                (limit sq) -- limit
268 |                                (expToOrder $ sort sq) -- sort
269 |                                False 0 []
270 | 
271 | -- | Class defining a selectable type. Type 'a' corresponds to the
272 | -- record type, 'f' corresponds to the field or facet, and 't'
273 | -- corresponds to the field/facet type.
274 | class Val t => Selectable a f t | f -> a, f -> t where
275 |   -- | Given facet, return the BSON field name
276 |   s :: f -> t -> Label
277 | 
278 | -- | Nested fields (used for extracting the names of fields in a
279 | -- nested record). 
280 | data Nested f f' = Nested Label
281 | 
282 | -- | Combining two field names to create a 'Nested' type.
283 | (.!) :: (Selectable r f t, Selectable t f' t') => f -> f' -> Nested f f'
284 | (.!) f f' = Nested $ intercalate (u ".") [(s f undefined), (s f' undefined)]
285 | 
286 | instance (Selectable r f t, Selectable t f' t') =>
287 |           Selectable r (Nested f f') t' where
288 |   s (Nested l) _ = l
289 | 
290 | -- | A query expression.
291 | data QueryExp a = StarExp
292 |                 | EqExp   !Label   !Value
293 |                 | LBinExp !UString !Label !Value
294 |                 | AndExp  (QueryExp a) (QueryExp a) 
295 |                 | OrExp   (QueryExp a) (QueryExp a) 
296 |                 | NotExp  (QueryExp a)
297 |                 deriving (Eq, Show)
298 | 
299 | infix   9 .! 
300 | infix   4 .==, ./=, .<, .<=, .>, .>=
301 | infixr  3 .&&
302 | infixr  2 .||
303 | 
304 | -- | Combinator for @==@
305 | (.*) :: (Structured a) => QueryExp a
306 | (.*) = StarExp
307 | 
308 | -- | Combinator for @==@
309 | (.==) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
310 | (.==) f v = EqExp  (s f v) (val v)
311 | 
312 | -- | Combinator for @$ne@
313 | (./=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
314 | (./=) f v = LBinExp (u "$ne") (s f v) (val v)
315 | 
316 | -- | Combinator for @<@
317 | (.< ) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
318 | (.< ) f v = LBinExp (u "$lt") (s f v) (val v)
319 | 
320 | -- | Combinator for @<=@
321 | (.<=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
322 | (.<=) f v = LBinExp (u "$lte") (s f v) (val v)
323 | 
324 | -- | Combinator for @>@
325 | (.> ) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
326 | (.> ) f v = LBinExp (u "$gt") (s f v) (val v)
327 | 
328 | -- | Combinator for @>=@
329 | (.>=) :: (Val t, Selectable a f t) => f -> t -> QueryExp a
330 | (.>=) f v = LBinExp (u "$gte") (s f v) (val v)
331 | 
332 | -- | Combinator for @$and@
333 | (.&&) :: QueryExp a -> QueryExp a -> QueryExp a
334 | (.&&) = AndExp
335 | 
336 | -- | Combinator for @$or@
337 | (.||) :: QueryExp a -> QueryExp a -> QueryExp a
338 | (.||) = OrExp
339 | 
340 | -- | Combinator for @$not@
341 | not_ :: QueryExp a -> QueryExp a
342 | not_ = NotExp
343 | 
344 | -- | Convert a query expression to a 'Selector'.
345 | expToSelector :: Structured a => QueryExp a -> M.Selector
346 | expToSelector (StarExp)        = [ ]
347 | expToSelector (EqExp l v)      = [ l := v ]
348 | expToSelector (LBinExp op l v) = [ l =: [ op := v ]]
349 | expToSelector (AndExp e1 e2)   = [ (u "$and") =: [expToSelector e1
350 |                                                  , expToSelector e2] ]
351 | expToSelector (OrExp e1 e2)    = [ (u "$or") =: [expToSelector e1
352 |                                                 , expToSelector e2] ]
353 | expToSelector (NotExp e)       = [ (u "$not") =: expToSelector e]
354 | 
355 | -- | Convert query expression to 'Selection'.
356 | expToSelection :: Structured a => QueryExp a -> M.Selection
357 | expToSelection e = M.Select { M.selector = (expToSelector e)
358 |                             , M.coll = (collection . c $ e) }
359 |   where c :: Structured a => QueryExp a -> a
360 |         c _ = undefined
361 | 
362 | -- | An ordering expression
363 | data OrderExp = Desc Label
364 |               | Asc Label
365 |   deriving(Eq, Show)
366 | 
367 | -- | Sort by field, ascending
368 | asc :: Selectable a f t => f -> OrderExp
369 | asc f = Asc (s f undefined)
370 | 
371 | -- | Sort by field, descending
372 | desc :: Selectable a f t => f -> OrderExp
373 | desc f = Desc (s f undefined)
374 | 
375 | -- | Convert a list of @OrderExp@ to a @mongoDB@ @Order@
376 | expToOrder :: [OrderExp] -> M.Order
377 | expToOrder exps = map _expToLabel exps
378 |   where _expToLabel (Desc fieldName) = fieldName := val (-1 :: Int)
379 |         _expToLabel (Asc fieldName) = fieldName := val (1 :: Int)
380 | 
381 | 


--------------------------------------------------------------------------------