diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,10 @@ ## [Unreleased] +## [0.0.0.15] - 2019-01-22 +### Changed +- Ability to choose whether to return entity or not in graphs. + ## [0.0.0.14] - 2018-12-25 ### Added - `mergeGraphs`, ability to take not all node properties from DB. diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.Exception (bracket) +import Control.Monad.State (execState, modify) +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy.Char8 as B (putStrLn) +import Data.Default (def) +import Data.Map.Strict ((!)) +import Data.Text (Text) +import Database.Bolt (BoltActionT, BoltCfg (..), + Value (..), close, connect, run) +import Database.Bolt.Extras (NodeLike (..), + URelationLike (..)) +import Database.Bolt.Extras.Graph +import Database.Bolt.Extras.Template (makeNodeLike, makeURelationLike) +import GHC.Generics (Generic) + +-- | Configuration for connection to local database. +boltCfg :: BoltCfg +boltCfg = def { host = "localhost" + , user = "neo4j" + , password = "12345" + } + +-- | Helper to run queries in Neo4j DB. +-- +runQueryDB :: BoltActionT IO a -> IO a +runQueryDB act = bracket (connect boltCfg) close (`run` act) + +data ExampleNode = ExampleNode { exampleFieldT :: Text + , exampleFieldI :: Int + } + deriving (Show, Generic) + +data EXAMPLE_RELATION = EXAMPLE_RELATION + deriving (Show, Generic) + +makeNodeLike ''ExampleNode +makeURelationLike ''EXAMPLE_RELATION + +exNodeAVar :: Text +exNodeAVar = "nodeA" + +exNodeBVar :: Text +exNodeBVar = "nodeB" + +-- | Builds query: +-- CREATE (nodeA:ExampleNode { exampleFieldT: "A" , exampleFieldI: 1}) WITH nodeA +-- MERGE (nodeB:ExampleNode { exampleFieldT: "B" , exampleFieldI: 2}) WITH nodeB +-- MERGE (nodeA)-[nodeA0nodeB:EXAMPLE_RELATION]-(nodeB) WITH nodeA, nodeB, nodeA0nodeB +-- RETURN ID(nodeA), ID(nodeB), ID(nodeA0nodeB) +-- +examplePutGraph :: GraphPutRequest +examplePutGraph = flip execState emptyGraph $ do + modify $ addNode exNodeAVar (CreateN . toNode $ exNodeA) + modify $ addNode exNodeBVar (MergeN . toNode $ exNodeB) + + modify $ addRelation exNodeAVar exNodeBVar (MergeR . toURelation $ exRel) + where + exNodeA = ExampleNode "A" 1 + exNodeB = ExampleNode "B" 2 + exRel = EXAMPLE_RELATION + +-- | Builds query: +-- MATCH (nodeA)-[:EXAMPLE_RELATION]-(nodeB), +-- (nodeA:ExampleNode { exampleField: "A" }), +-- (nodeB:ExampleNode { exampleField: "B" }) +-- RETURN { id: ID(nodeA), labels: labels(nodeA), props: properties(nodeA) } +-- +exampleGetGraphB :: GraphGetRequest +exampleGetGraphB = flip execState emptyGraph $ do + modify $ addNode exNodeAVar exNodeA + modify $ addNode exNodeBVar exNodeB + + modify $ addRelation exNodeAVar exNodeBVar exRel + where + exNodeA = defaultNodeReturn # withLabelQ ''ExampleNode + # withProp ("exampleFieldT", T "A") + # withReturn allProps + + exNodeB = defaultNodeNotReturn # withLabelQ ''ExampleNode + # withProp ("exampleFieldT", T "B") + + exRel = defaultRelNotReturn # withLabelQ ''EXAMPLE_RELATION + +-- | Builds query: +-- MATCH (nodeA:ExampleNode { exampleField: "A" }) +-- RETURN { id: ID(nodeA), labels: labels(nodeA), props: nodeA {.exampleFieldI} } +-- +exampleGetGraphA :: GraphGetRequest +exampleGetGraphA = flip execState emptyGraph $ + modify $ addNode exNodeAVar exNodeA + where + exNodeA = defaultNodeReturn # withLabelQ ''ExampleNode + # withProp ("exampleFieldT", T "A") + # withReturn ["exampleFieldI"] + +-- | Put 'examplePutGraph' to the database. +-- +putGraph :: IO () +putGraph = do + putGraphR <- runQueryDB $ makeRequest @PutRequestB [] examplePutGraph + putStrLn "Uploaded graph: " + print putGraphR + +-- Get 'exampleGetGraphB' and parse it to Haskell object. +-- +getGraphB :: IO () +getGraphB = do + getGraphsR <- runQueryDB $ makeRequest @GetRequestB [] exampleGetGraphB + let nodesA :: [ExampleNode] = fromNode . (! exNodeAVar) . _vertices <$> getGraphsR + putStrLn "Downloaded graph and converted to Haskell object: " + print nodesA + +-- Get 'exampleGetGraphA' and parse it to JSON. +-- +getGraphA :: IO () +getGraphA = do + getGraphsR <- runQueryDB $ makeRequest @GetRequestA [] exampleGetGraphA + let nodesA = (! exNodeAVar) . _vertices <$> getGraphsR + putStrLn "Downloaded graph and converted to JSON: " + B.putStrLn . encode $ nodesA + +main :: IO () +main = putGraph >> getGraphB >> getGraphA diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal --- a/hasbolt-extras.cabal +++ b/hasbolt-extras.cabal @@ -1,5 +1,5 @@ name: hasbolt-extras -version: 0.0.0.14 +version: 0.0.0.15 synopsis: Extras for hasbolt library description: Extras for hasbolt library homepage: https://github.com/biocad/hasbolt-extras#readme @@ -64,3 +64,18 @@ , unordered-containers ghc-options: -Wall -O2 default-language: Haskell2010 + +executable example + hs-source-dirs: example + main-is: Main.hs + build-depends: base >= 4.7 && < 5 + , aeson + , bytestring + , containers + , data-default + , hasbolt + , hasbolt-extras + , mtl + , text + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2 diff --git a/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs b/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs --- a/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Database.Bolt.Extras.Graph.Internal.AbstractGraph ( @@ -8,10 +10,15 @@ , emptyGraph , addNode , addRelation + , NodeName + , relationName ) where import Control.Lens (makeLenses, over) import Data.Map.Strict (Map, insert, notMember) +import Data.Monoid ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) import Text.Printf (printf) -- | 'Graph' contains vertices, that are parameterized by some type @n@, and relations, @@ -19,7 +26,7 @@ -- data Graph n a b = Graph { _vertices :: Map n a , _relations :: Map (n, n) b - } deriving (Show) + } deriving (Show, Generic) makeLenses ''Graph @@ -43,3 +50,12 @@ addRelation startName endName rel graph = if (startName, endName) `notMember` _relations graph then over relations (insert (startName, endName) rel) graph else error $ printf "relation with names (%s, %s) already exists" (show startName) (show endName) + +-- | Alias for text node name. +-- +type NodeName = Text + +-- | Creates relationship name from the names of its start and end nodes +-- in the way `0`. +relationName :: (NodeName, NodeName) -> Text +relationName (st, en) = st <> "0" <> en diff --git a/src/Database/Bolt/Extras/Graph/Internal/Class.hs b/src/Database/Bolt/Extras/Graph/Internal/Class.hs --- a/src/Database/Bolt/Extras/Graph/Internal/Class.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/Class.hs @@ -12,14 +12,15 @@ -- | Class describes entity, which can be requested. -- class Requestable a where - -- | Condition for BoltId like "ID(a) = b" if BoltId is presented. - maybeBoltIdCond :: a -> Maybe Text -- | How to convert entity to Cypher. request :: a -> Text -- | Class describes entity, which can be returned. -- class Returnable a where + -- | If the entity should be returned. + isReturned' :: a -> Bool + -- | How to return entity in the Cypher. return' :: a -> Text diff --git a/src/Database/Bolt/Extras/Graph/Internal/Get.hs b/src/Database/Bolt/Extras/Graph/Internal/Get.hs --- a/src/Database/Bolt/Extras/Graph/Internal/Get.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/Get.hs @@ -6,19 +6,25 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Bolt.Extras.Graph.Internal.Get ( - NodeName -- * Types for requesting nodes and relationships - , NodeGetter (..) + NodeGetter (..) , RelGetter (..) , GetterLike (..) , (#) , defaultNode , defaultRel + , defaultNodeReturn + , defaultNodeNotReturn + , defaultRelReturn + , defaultRelNotReturn + , requestGetters + , allProps -- * Types for extracting nodes and relationships , NodeResult (..) , RelResult (..) @@ -48,7 +54,8 @@ insert, toList, (!)) -import Data.Maybe (fromJust, +import Data.Maybe (catMaybes, + fromJust, isJust) import Data.Monoid ((<>)) import Data.Text (Text, cons, @@ -64,80 +71,96 @@ NodeLike (..), ToCypher (..), URelationLike (..)) -import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph) +import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph, + NodeName, + relationName) import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..), Requestable (..), Returnable (..)) import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Name, + nameBase) import NeatInterpolation (text) import Text.Printf (printf) --- | Alias for node name --- -type NodeName = Text - ---------------------------------------------------------- -- REQUEST -- ---------------------------------------------------------- -- | Helper to find 'Node's. -- -data NodeGetter = NodeGetter { ngboltId :: Maybe BoltId - , ngLabels :: [Label] - , ngProps :: Map Text B.Value - , ngReturnProps :: [Text] +data NodeGetter = NodeGetter { ngboltId :: Maybe BoltId -- ^ known boltId + , ngLabels :: [Label] -- ^ known labels + , ngProps :: Map Text B.Value -- ^ known properties + , ngReturnProps :: [Text] -- ^ names of properties to return + , ngIsReturned :: Bool -- ^ whether return this node or not } deriving (Show, Eq) -- | Helper to find 'URelationship's. -- -data RelGetter = RelGetter { rgboltId :: Maybe BoltId - , rgLabel :: Maybe Label - , rgProps :: Map Text B.Value - , rgReturnProps :: [Text] +data RelGetter = RelGetter { rgboltId :: Maybe BoltId -- ^ known boltId + , rgLabel :: Maybe Label -- ^ known labels + , rgProps :: Map Text B.Value -- ^ known properties + , rgReturnProps :: [Text] -- ^ names of properties to return + , rgIsReturned :: Bool -- ^ whether return this relation or not } deriving (Show, Eq) (#) :: a -> (a -> b) -> b (#) = (&) -defaultNode :: NodeGetter +defaultNode :: Bool -> NodeGetter defaultNode = NodeGetter Nothing [] (fromList []) [] -defaultRel :: RelGetter +defaultRel :: Bool -> RelGetter defaultRel = RelGetter Nothing Nothing (fromList []) [] +defaultNodeReturn :: NodeGetter +defaultNodeReturn = defaultNode True + +defaultNodeNotReturn :: NodeGetter +defaultNodeNotReturn = defaultNode False + +defaultRelReturn :: RelGetter +defaultRelReturn = defaultRel True + +defaultRelNotReturn :: RelGetter +defaultRelNotReturn = defaultRel False + -- | Helper to work with Getters. -- class GetterLike a where - withBoltId :: BoltId -> a -> a - withLabel :: Label -> a -> a - withProp :: (Text, B.Value) -> a -> a - withReturn :: [Text] -> a -> a + withBoltId :: BoltId -> a -> a -- ^ set known boltId + withLabel :: Label -> a -> a -- ^ set known label + withLabelQ :: Name -> a -> a -- ^ set known label as 'Name' + withProp :: (Text, B.Value) -> a -> a -- ^ add known property + withReturn :: [Text] -> a -> a -- ^ add list of properties to return + isReturned :: a -> a -- ^ set that current node should be returned instance GetterLike NodeGetter where - withBoltId boltId ng = ng { ngboltId = Just boltId } - withLabel lbl ng = ng { ngLabels = lbl : ngLabels ng } - withProp (pk, pv) ng = ng { ngProps = insert pk pv (ngProps ng) } - withReturn props ng = ng { ngReturnProps = ngReturnProps ng ++ props } + withBoltId boltId ng = ng { ngboltId = Just boltId } + withLabel lbl ng = ng { ngLabels = lbl : ngLabels ng } + withLabelQ lblQ = withLabel (pack . nameBase $ lblQ) + withProp (pk, pv) ng = ng { ngProps = insert pk pv (ngProps ng) } + withReturn props ng = ng { ngReturnProps = ngReturnProps ng ++ props } + isReturned ng = ng { ngIsReturned = True } instance GetterLike RelGetter where - withBoltId boltId rg = rg { rgboltId = Just boltId } - withLabel lbl rg = rg { rgLabel = Just lbl } - withProp (pk, pv) rg = rg { rgProps = insert pk pv (rgProps rg) } - withReturn props rg = rg { rgReturnProps = rgReturnProps rg ++ props } + withBoltId boltId rg = rg { rgboltId = Just boltId } + withLabel lbl rg = rg { rgLabel = Just lbl } + withLabelQ lblQ = withLabel (pack . nameBase $ lblQ) + withProp (pk, pv) rg = rg { rgProps = insert pk pv (rgProps rg) } + withReturn props rg = rg { rgReturnProps = rgReturnProps rg ++ props } + isReturned rg = rg { rgIsReturned = True } instance Requestable (NodeName, NodeGetter) where - maybeBoltIdCond (name, ng) = pack . printf "ID(%s)=%d" name <$> ngboltId ng - request (name, ng) = [text|($name $labels $propsQ)|] where labels = toCypher . ngLabels $ ng propsQ = "{" <> (toCypher . toList . ngProps $ ng) <> "}" instance Requestable ((NodeName, NodeName), RelGetter) where - maybeBoltIdCond (names, rg) = pack . printf "ID(%s)=%d" (relationName names) <$> rgboltId rg - request ((stName, enName), rg) = [text|($stName)-[$name $typeQ $propsQ]-($enName)|] where name = relationName (stName, enName) @@ -145,35 +168,57 @@ propsQ = "{" <> (toCypher . toList . rgProps $ rg) <> "}" instance Returnable (NodeName, NodeGetter) where - return' (name, ng) = let showProps = showRetProps name $ ngReturnProps ng - in [text|{ id: id($name), - labels: labels($name), - props: $showProps - } as $name - |] + isReturned' (_, ng) = ngIsReturned ng + return' (name, ng) = let showProps = showRetProps name $ ngReturnProps ng + in [text|{ id: id($name), + labels: labels($name), + props: $showProps + } as $name + |] + instance Returnable ((NodeName, NodeName), RelGetter) where + isReturned' (_, rg) = rgIsReturned rg + return' ((stName, enName), rg) = let name = relationName (stName, enName) showProps = showRetProps name $ rgReturnProps rg - in [text|{ id: id($name), - label: type($name), - props: $showProps - } as $name - |] + in [text|{ id: id($name), + label: type($name), + props: $showProps + } as $name + |] --- | Creates relationship name from the names of its start and end nodes --- in the way `0`. -relationName :: (NodeName, NodeName) -> Text -relationName (st, en) = st <> "0" <> en +allProps :: [Text] +allProps = ["*"] showRetProps :: Text -> [Text] -> Text -showRetProps name [] = "properties(" <> name <> ")" +showRetProps name [] = name <> "{}" +showRetProps name ["*"] = "properties(" <> name <> ")" showRetProps name props = name <> "{" <> intercalate ", " (cons '.' <$> props) <> "}" +-- | Takes all node getters and relationship getters +-- and write them to single query to request. +-- Also return conditions on known boltId-s. +-- +requestGetters :: [(NodeName, NodeGetter)] + -> [((NodeName, NodeName), RelGetter)] + -> (Text, [Text]) +requestGetters ngs rgs = ("MATCH " <> intercalate ", " (fmap request rgs ++ fmap request ngs), conditionsID) + where + boltIdCondN :: (NodeName, NodeGetter) -> Maybe Text + boltIdCondN (name, ng) = pack . printf "ID(%s)=%d" name <$> ngboltId ng + + boltIdCondR :: ((NodeName, NodeName), RelGetter) -> Maybe Text + boltIdCondR (names, rg) = pack . printf "ID(%s)=%d" (relationName names) <$> rgboltId rg + + conditionsID = catMaybes (fmap boltIdCondN ngs ++ fmap boltIdCondR rgs) + ---------------------------------------------------------- -- RESULT -- ---------------------------------------------------------- +-- | AESON FORMAT + -- | Result for node in the Aeson like format. -- data NodeResult = NodeResult { nresId :: BoltId @@ -216,13 +261,16 @@ instance Extractable RelResult where extract = extractFromJSON +---------------------------------------------------------- +-- | BOLT FORMAT + instance Extractable Node where extract :: forall m. MonadIO m => Text -> [Record] -> BoltActionT m [Node] - extract t rec = (toNode <$>) <$> (extractFromJSON t rec :: BoltActionT m [NodeResult]) + extract t rec = fmap toNode <$> extractFromJSON @ _ @ NodeResult t rec instance Extractable URelationship where extract :: forall m. MonadIO m => Text -> [Record] -> BoltActionT m [URelationship] - extract t rec = (toURelation <$>) <$> (extractFromJSON t rec :: BoltActionT m [RelResult]) + extract t rec = fmap toURelation <$> extractFromJSON @ _ @ RelResult t rec extractFromJSON :: (MonadIO m, FromJSON a) => Text -> [Record] -> BoltActionT m [a] extractFromJSON var = pure . fmap (\r -> case fromJSON (toJSON (r ! var)) of @@ -238,8 +286,8 @@ fromNode Node{..} = NodeResult nodeIdentity labels (toJSON <$> nodeProps) instance URelationLike RelResult where - toURelation RelResult{..} = URelationship rresId rresLabel (fromJust <$> M.filter isJust (fromJSONM <$> rresProps)) - fromURelation URelationship{..} = RelResult urelIdentity urelType (toJSON <$> urelProps) + toURelation RelResult{..} = URelationship rresId rresLabel (fromJust <$> M.filter isJust (fromJSONM <$> rresProps)) + fromURelation URelationship{..} = RelResult urelIdentity urelType (toJSON <$> urelProps) ---------------------------------------------------------- -- GRAPH TYPES -- diff --git a/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs b/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs --- a/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs @@ -13,6 +13,7 @@ GraphQuery (..) , GetRequestA (..) , GetRequestB (..) + , PutRequestB (..) , mergeGraphs ) where @@ -20,35 +21,36 @@ import Control.Monad.IO.Class (MonadIO) import Data.List (foldl') import Data.Map.Strict (fromList, - keys, mapKeys, mapWithKey, toList, union, (!)) -import Data.Maybe (catMaybes) import Data.Monoid ((<>)) -import Data.Text (Text, - intercalate, - pack) +import Data.Text as T (Text, intercalate, + null, + pack) import Database.Bolt (BoltActionT, Node, Record, URelationship, query) -import Database.Bolt.Extras (GetBoltId (..)) +import Database.Bolt.Extras (BoltId, GetBoltId (..)) import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..), + NodeName, emptyGraph, + relationName, relations, vertices) import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..), Requestable (..), Returnable (..)) import Database.Bolt.Extras.Graph.Internal.Get (NodeGetter, - NodeName, NodeResult, RelGetter, RelResult, - relationName) + requestGetters) +import Database.Bolt.Extras.Graph.Internal.Put (PutNode, PutRelationship, + requestPut) import NeatInterpolation (text) -- | Type family used to perform requests to the Neo4j based on graphs. @@ -63,10 +65,14 @@ -- | Type of relationship entity, which will be extracted from result. type RelRes a :: * - -- | 'MATCH' or 'MERGE' or 'CREATE' - clause :: Text + -- | How to convert requestable entities to text in the query. + requestEntities :: (Requestable (NodeName, NodeReq a), + Requestable ((NodeName, NodeName), RelReq a)) + => [(NodeName, NodeReq a)] + -> [((NodeName, NodeName), RelReq a)] + -> (Text, [Text]) - -- | Abstract function to form query for get request. + -- | Abstract function to form query for request. -- formQuery :: (Requestable (NodeName, NodeReq a), Requestable ((NodeName, NodeName), RelReq a), @@ -75,27 +81,22 @@ => [Text] -> Graph NodeName (NodeReq a) (RelReq a) -> Text - formQuery customConds graph = [text|$clause' $completeRequest + formQuery customConds graph = [text|$completeRequest $conditionsQ - RETURN $completeReturn|] + RETURN DISTINCT $completeReturn|] where - clause' = clause @a - vertices' = toList (graph ^. vertices) relations' = toList (graph ^. relations) - requestVertices = request <$> vertices' - requestRelations = request <$> relations' + (completeRequest, reqConds) = requestEntities @a vertices' relations' - conditionsID = catMaybes (fmap maybeBoltIdCond vertices' ++ fmap maybeBoltIdCond relations') - conditions = customConds ++ conditionsID - conditionsQ = if null conditions then "" else "WHERE " <> intercalate " AND " conditions + conditions = reqConds ++ customConds + conditionsQ = if Prelude.null conditions then "" else " WHERE " <> intercalate " AND " conditions - returnVertices = return' <$> vertices' - returnRelations = return' <$> relations' + returnVertices = return' <$> filter isReturned' vertices' + returnRelations = return' <$> filter isReturned' relations' - completeRequest = intercalate ", " $ requestVertices ++ requestRelations - completeReturn = intercalate ", " $ returnVertices ++ returnRelations + completeReturn = intercalate ", " $ Prelude.filter (not . T.null) $ returnVertices ++ returnRelations -- | Abstract function, which exctracts graph from records if nodes and relations can be extracted. -- @@ -124,8 +125,15 @@ -> BoltActionT m [Graph NodeName (NodeRes a) (RelRes a)] makeRequest conds graph = do response <- query $ formQuery @a conds graph - extractGraphs @a (keys $ graph ^. vertices) (keys $ graph ^. relations) response + extractGraphs @a presentedVertices presentedRelations response + where + presentedVertices = fmap fst . filter isReturned' . toList $ graph ^. vertices + presentedRelations = fmap fst . filter isReturned' . toList $ graph ^. relations +--------------------------------------------------------------------------------------- +-- GET -- +--------------------------------------------------------------------------------------- + -- | Get request with result in Aeson format. -- Easy way to show result graphs. -- @@ -141,14 +149,29 @@ type RelReq GetRequestA = RelGetter type NodeRes GetRequestA = NodeResult type RelRes GetRequestA = RelResult - clause = "MATCH" + requestEntities = requestGetters instance GraphQuery GetRequestB where type NodeReq GetRequestB = NodeGetter type RelReq GetRequestB = RelGetter type NodeRes GetRequestB = Node type RelRes GetRequestB = URelationship - clause = "MATCH" + requestEntities = requestGetters + +--------------------------------------------------------------------------------------- +-- PUT -- +--------------------------------------------------------------------------------------- + +-- | Put request in Bolt format with 'BoltId's of uploaded entities as result. +-- +data PutRequestB = PutRequestB + +instance GraphQuery PutRequestB where + type NodeReq PutRequestB = PutNode + type RelReq PutRequestB = PutRelationship + type NodeRes PutRequestB = BoltId + type RelRes PutRequestB = BoltId + requestEntities = requestPut -- | Helper function to merge graphs of results, i.e. -- if you requested graph A->B->C diff --git a/src/Database/Bolt/Extras/Graph/Internal/Put.hs b/src/Database/Bolt/Extras/Graph/Internal/Put.hs --- a/src/Database/Bolt/Extras/Graph/Internal/Put.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/Put.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Bolt.Extras.Graph.Internal.Put ( @@ -8,31 +10,33 @@ , PutRelationship (..) , GraphPutRequest , GraphPutResponse - , putNode - , putRelationship - , putGraph + , requestPut ) where -import Control.Monad (forM) -import Control.Monad.IO.Class (MonadIO) -import Data.Map.Strict (mapWithKey, - toList, (!)) -import qualified Data.Map.Strict as M (map) -import qualified Data.Text as T (Text, - pack) -import Database.Bolt (BoltActionT, - Node (..), - RecordValue (..), +import Data.List (foldl') +import Data.Map.Strict (toList, (!)) +import Data.Monoid ((<>)) +import Data.Text (Text, + intercalate, + pack) +import Database.Bolt (Node (..), RecordValue (..), URelationship (..), Value (..), - at, exact, - query) + exact) import Database.Bolt.Extras (BoltId, ToCypher (..), fromInt) -import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..)) +import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..), + NodeName, + relationName) +import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..), + Requestable (..), + Returnable (..)) import NeatInterpolation (text) -type NodeName = T.Text +------------------------------------------------------------------------------------------------ +-- REQUEST -- +------------------------------------------------------------------------------------------------ +-- | BOLT FORMAT -- | 'PutNode' is the wrapper for 'Node' where we can specify if we want to merge or create it. -- @@ -44,82 +48,83 @@ data PutRelationship = MergeR URelationship | CreateR URelationship deriving (Show) --- | The graph of 'Node's with specified uploading type and 'URelationship's. --- -type GraphPutRequest = Graph NodeName PutNode PutRelationship - --- | The graph of 'BoltId's corresponding to the nodes and relationships --- which we get after putting 'GraphPutRequest'. --- -type GraphPutResponse = Graph NodeName BoltId BoltId +instance Requestable (NodeName, PutNode) where + request (name, BoltId boltId) = let showBoltId = pack . show $ boltId + in [text|MATCH ($name) WHERE ID($name) = $showBoltId|] + request (name, MergeN node) = requestNode "MERGE" name node + request (name, CreateN node) = requestNode "CREATE" name node --- | For given @Node _ labels nodeProps@ makes query MERGE or CREATE depending --- on the type of 'PutNode' and returns 'BoltId' of the loaded 'Node'. --- If we already know 'BoltId' of the 'Node' with such parameters, this function does nothing. --- --- Potentially, if you MERGE some 'Node' and its labels and props are occured in --- several 'Node's, then the result can be not one but several 'Node's, --- so the result of this function will be a list of corresponding 'BoltId's. --- -putNode :: (MonadIO m) => PutNode -> BoltActionT m [BoltId] -putNode ut = case ut of - (BoltId bId) -> pure [bId] - (MergeN node) -> helper (T.pack "MERGE") node - (CreateN node) -> helper (T.pack "CREATE") node +requestNode :: Text -> NodeName -> Node -> Text +requestNode q name Node{..} = [text|$q ($name $labelsQ {$propsQ})|] where - helper :: (MonadIO m) => T.Text -> Node -> BoltActionT m [BoltId] - helper q node = do - let varQ = "n" - - let labelsQ = toCypher $ labels node - let propsQ = toCypher . filter ((/= N ()) . snd) . toList $ nodeProps node + labelsQ = toCypher labels + propsQ = toCypher . filter ((/= N ()) . snd) . toList $ nodeProps - let getQuery = [text|$q ($varQ $labelsQ {$propsQ}) - RETURN ID($varQ) as $varQ|] +instance Requestable ((NodeName, NodeName), PutRelationship) where + request (names, MergeR urel) = requestURelationship "MERGE" names urel + request (names, CreateR urel) = requestURelationship "CREATE" names urel - records <- query getQuery - forM records $ \record -> do - nodeIdentity' <- record `at` varQ >>= exact - pure $ fromInt nodeIdentity' +requestURelationship :: Text -> (NodeName, NodeName) -> URelationship -> Text +requestURelationship q (stName, enName) URelationship{..} = + [text|$q ($stName)-[$name $labelQ {$propsQ}]->($enName)|] + where + name = relationName (stName, enName) + labelQ = toCypher urelType + propsQ = toCypher . toList $ urelProps --- | Every relationship in Bolt protocol starts from one 'Node' and ends in anoter. --- For given starting and ending 'Node's 'BoltId's, and for @URelationship _ urelType urelProps@ --- this method makes MERGE query and then returns the corresponding 'BoltId'. --- -putRelationship :: (MonadIO m) => BoltId -> PutRelationship -> BoltId -> BoltActionT m BoltId -putRelationship start pr end = case pr of - (MergeR relationship) -> helper (T.pack "MERGE") relationship - (CreateR relationship) -> helper (T.pack "CREATE") relationship +-- | Takes all 'PutNode's and 'PutRelationship's +-- and write them to single query to request. +-- Here "WITH" is used, because you cannot perform +-- "match", "merge" or "create" at the same query. +requestPut :: [(NodeName, PutNode)] + -> [((NodeName, NodeName), PutRelationship)] + -> (Text, [Text]) +requestPut pns prs = (fst fullRequest, []) where - helper :: (MonadIO m) => T.Text -> URelationship -> BoltActionT m BoltId - helper q URelationship{..} = do - [record] <- query putQuery - urelIdentity' <- record `at` varQ >>= exact - pure $ fromInt urelIdentity' + foldStepN :: (Text, [NodeName]) -> (NodeName, PutNode) -> (Text, [NodeName]) + foldStepN accum pn@(name, _) = foldStep accum name pn + + foldStepR :: (Text, [NodeName]) -> ((NodeName, NodeName), PutRelationship) -> (Text, [NodeName]) + foldStepR accum pr@(names, _) = foldStep accum (relationName names) pr + + foldStep :: Requestable a => (Text, [NodeName]) -> NodeName -> a -> (Text, [NodeName]) + foldStep (currentQuery, names) name put = + (currentQuery <> request put <> " WITH " <> intercalate ", " updNames <> " ", updNames) where - varQ = "r" - labelQ = toCypher urelType - propsQ = toCypher . toList $ urelProps - startT = T.pack . show $ start - endT = T.pack . show $ end + updNames = name : names - putQuery :: T.Text - putQuery = [text|MATCH (a), (b) - WHERE ID(a) = $startT AND ID(b) = $endT - $q (a)-[$varQ $labelQ {$propsQ}]->(b) - RETURN ID($varQ) as $varQ|] + requestNodes = foldl' foldStepN ("", []) pns + fullRequest = foldl' foldStepR requestNodes prs --- | Creates graph using given 'GraphPutRequest'. --- If there were multiple choices while merging given _vertices, the first match is used for connection. +instance Returnable (NodeName, PutNode) where + -- always return all nodes + isReturned' _ = True + return' (name, _) = [text|ID($name) AS $name|] + +instance Returnable ((NodeName, NodeName), PutRelationship) where + -- always return all relations + isReturned' _ = True + return' (names, _) = let name = relationName names + in [text|ID($name) AS $name|] + +------------------------------------------------------------------------------------------------ + +---------------------------------------------------------- +-- RESULT -- +---------------------------------------------------------- + +instance Extractable BoltId where + extract name = mapM (fmap fromInt . exact . (! name)) + +---------------------------------------------------------- +-- GRAPH TYPES -- +---------------------------------------------------------- + +-- | The graph of 'Node's with specified uploading type and 'URelationship's. -- -putGraph :: (MonadIO m) => GraphPutRequest -> BoltActionT m GraphPutResponse -putGraph requestGraph = do - let vertices' = _vertices requestGraph - let rels = _relations requestGraph - nodes <- sequenceA $ M.map (fmap head . putNode) vertices' - edges <- sequenceA $ - mapWithKey (\key v -> do - let stNode = nodes ! fst key - let endNode = nodes ! snd key - putRelationship stNode v endNode) rels - return $ Graph nodes edges +type GraphPutRequest = Graph NodeName PutNode PutRelationship + +-- | The graph of 'BoltId's corresponding to the nodes and relationships +-- which we get after putting 'GraphPutRequest'. +-- +type GraphPutResponse = Graph NodeName BoltId BoltId