hasbolt-extras 0.0.0.14 → 0.0.0.15
raw patch · 8 files changed
+415/−172 lines, 8 filesdep +bytestringdep +data-defaultdep +hasbolt-extrasnew-component:exe:example
Dependencies added: bytestring, data-default, hasbolt-extras
Files
- CHANGELOG.md +4/−0
- example/Main.hs +131/−0
- hasbolt-extras.cabal +16/−1
- src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs +18/−2
- src/Database/Bolt/Extras/Graph/Internal/Class.hs +3/−2
- src/Database/Bolt/Extras/Graph/Internal/Get.hs +102/−54
- src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs +50/−27
- src/Database/Bolt/Extras/Graph/Internal/Put.hs +91/−86
CHANGELOG.md view
@@ -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.
+ example/Main.hs view
@@ -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
hasbolt-extras.cabal view
@@ -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
src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs view
@@ -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 `<startNodeName>0<endNodeName>`.+relationName :: (NodeName, NodeName) -> Text+relationName (st, en) = st <> "0" <> en
src/Database/Bolt/Extras/Graph/Internal/Class.hs view
@@ -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
src/Database/Bolt/Extras/Graph/Internal/Get.hs view
@@ -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 `<startNodeName>0<endNodeName>`.-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 --
src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs view
@@ -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
src/Database/Bolt/Extras/Graph/Internal/Put.hs view
@@ -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