diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2014 Antoni Silvestre + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-neo4j-client.cabal b/haskell-neo4j-client.cabal new file mode 100644 --- /dev/null +++ b/haskell-neo4j-client.cabal @@ -0,0 +1,71 @@ +name: haskell-neo4j-client +version: 0.1.0.0 +synopsis: A Haskell neo4j client +description: + Library to interact with Neo4j databases. For now, its API covers basic operations for nodes, relationships, labels + and indexes and provides calls to use these in batch mode. + . + Cypher is not yet supported, but it hopefully will be very soon. + . + All code has been tested with Neo4j version 2.0.3 +homepage: https://github.com/asilvestre/haskell-neo4j-rest-client +license: MIT +license-file: LICENSE +author: Antoni Silvestre +maintainer: antoni.silvestre@gmail.com +copyright: (c) 2014 Antoni Silvestre +category: Database +build-type: Simple +cabal-version: >=1.8 + +Test-Suite test-haskell-neo4j-rest-client + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: src, tests + Main-is: IntegrationTests.hs + Build-Depends: base ==4.6.*, + bytestring ==0.10.*, + test-framework ==0.8.*, + test-framework-quickcheck2 ==0.3.*, + QuickCheck ==2.7.*, + test-framework-hunit ==0.3.*, + test-framework-th ==0.2.*, + HUnit ==1.2.*, + Cabal, + text ==1.1.*, + http-conduit ==2.1.*, + http-types ==0.8.*, + resourcet ==1.1.*, + data-default ==0.5.*, + transformers ==0.4.*, + aeson ==0.7.*, + vector ==0.10.*, + scientific ==0.3.*, + unordered-containers ==0.2.*, + HTTP ==4000.2.*, + lifted-base ==0.2.*, + hashable ==1.2.*, + mtl ==2.2.* +library + hs-source-dirs: src + exposed-modules: Database.Neo4j, Database.Neo4j.Graph, Database.Neo4j.Batch + other-modules: Database.Neo4j.Types, Database.Neo4j.Http, Database.Neo4j.Node, Database.Neo4j.Relationship, + Database.Neo4j.Property, Database.Neo4j.Label, Database.Neo4j.Index, Database.Neo4j.Batch.Node, + Database.Neo4j.Batch.Relationship, Database.Neo4j.Batch.Property, Database.Neo4j.Types, + Database.Neo4j.Batch.Label + build-depends: base ==4.6.*, + containers ==0.5.*, + text ==1.1.*, + http-conduit ==2.1.*, + http-types ==0.8.*, + bytestring ==0.10.*, + resourcet ==1.1.*, + data-default ==0.5.*, + transformers ==0.4.*, + aeson ==0.7.*, + vector ==0.10.*, + scientific ==0.3.*, + unordered-containers ==0.2.*, + HTTP ==4000.2.*, + lifted-base ==0.2.*, + hashable ==1.2.*, + mtl ==2.2.* diff --git a/src/Database/Neo4j.hs b/src/Database/Neo4j.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Database.Neo4j +-- Copyright: (c) 2014, Antoni Silvestre +-- License: MIT +-- Maintainer: Antoni Silvestre +-- Stability: experimental +-- Portability: portable +-- +-- Library to interact with the Neo4j REST API. +-- + +module Database.Neo4j ( + -- * How to use this library + -- $use + + -- * Connection handling objects + Connection, Hostname, Port, newConnection, withConnection, + -- * Main monadic type to handle sequences of commands to Neo4j + Neo4j, + -- * Constructing and managing node/relationship properties + Val(..), PropertyValue(..), newval, (|:), Properties, emptyProperties, getProperties, getProperty, setProperties, + setProperty, deleteProperties, deleteProperty, + -- * Managing nodes + Node, getNodeProperties, createNode, getNode, deleteNode, nodeId, nodePath, runNodeIdentifier, + -- * Managing relationships + Relationship, Direction(..), RelationshipType, createRelationship, getRelationship, deleteRelationship, + getRelationships, relId, relPath, allRelationshipTypes, getRelProperties, getRelType, runRelIdentifier, + getRelationshipFrom, getRelationshipTo, + -- * Managing labels and getting nodes by label + Label, allLabels, getLabels, getNodesByLabelAndProperty, addLabels, changeLabels, removeLabel, + -- * Indexes + Index(..), createIndex, getIndexes, dropIndex, + -- * Exceptions + Neo4jException(..) + ) where + +import Database.Neo4j.Index +import Database.Neo4j.Http +import Database.Neo4j.Label +import Database.Neo4j.Node +import Database.Neo4j.Relationship +import Database.Neo4j.Property +import Database.Neo4j.Types + +-- $use +-- +-- In order to start issuing commands to neo4j you must establish a connection, in order to do that you can use +-- the function 'withConnection': +-- +-- > withConnection "127.0.0.1" 7474 $ do +-- > neo <- createNode M.empty +-- > cypher <- createNode M.empty +-- > r <- createRelationship "KNOWS" M.empty neo cypher +-- > ... +-- +-- Also most calls have a batch analogue version, with batch mode you can issue several commands to Neo4j at once. +-- In order to issue batches you must use the "Database.Neo4j.Batch" monad, parameters in batch mode can be actual +-- entities already obtained by issuing regular commands or previous batch commands, or even batch futures, +-- that is you can refer to entities created in the same batch, for instance: +-- +-- > withConnection "127.0.0.1" 7474 $ do +-- > g <- B.runBatch $ do +-- > neo <- B.createNode M.empty +-- > cypher <- B.createNode M.empty +-- > B.createRelationship "KNOWS" M.empty neo cypher +-- > ... +-- +-- As you can see this example does the same thing the previous one does but it will be more efficient as it will +-- be translated into only one request to the database. +-- +-- Batch commands return a "Database.Neo4j.Graph" object that holds all the information about relationships, nodes +-- and their labels that can be inferred from running a batch command. +-- +-- Another example with batches would be for instance remove all the nodes in a "Database.Neo4j.Graph" object +-- +-- > withConnection "127.0.0.1" 7474 $ do +-- > ... +-- > B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) +-- +-- For more information about batch commands and graph objects you can refer to their "Database.Neo4j.Batch" and +-- "Database.Neo4j.Graph" modules. +-- +-- Properties are hashmaps with key 'Data.Text' and values a custom type called 'PropertyValue'. +-- This custom type tries to use Haskell's type system to match property values to what Neo4j expects, we only allow +-- 'Int64', 'Double', 'Bool' and 'Text' like values and one-level arrays of these. +-- The only restriction we cannot guarantee with these types is that arrays of values must be of the same type. +-- +-- In order to create a 'PropertyValue' from a literal or a value of one of the allowed types you can use the 'newval' +-- function or the operator '|:' to create pairs of key values: +-- +-- > import qualified Data.HashMap.Lazy as M +-- > +-- > myval = newval False +-- > someProperties = M.fromList ["mytext" |: ("mytext" :: T.Text), +-- > "textarrayprop" |: ["a" :: T.Text, "", "adeu"], +-- > "int" |: (-12 :: Int64), +-- > "intarray" |: [1 :: Int64, 2], +-- > "double" |: (-12.23 :: Double), +-- > "doublearray" |: [0.1, -12.23 :: Double], +-- > "bool" |: False, +-- > "aboolproparray" |: [False, True] +-- > ] +-- +-- When unexpected errors occur a 'Neo4jException' will be raised, sometimes with a specific exception value like for +-- instance 'Neo4jNoEntityException', or more generic ones like 'Neo4jHttpException' or 'Neo4jParseException' +-- if the server returns something totally unexpected. (I'm sure there's still work to do here preparing the code +-- to return more specific exceptions for known scenarios) diff --git a/src/Database/Neo4j/Batch.hs b/src/Database/Neo4j/Batch.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Batch.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Neo4j.Batch ( + -- * Usage + -- $use + + -- * General + Batch, runBatch, + -- * Nodes + createNode, getNode, deleteNode, + -- * Relationships + createRelationship, getRelationship, getRelationshipFrom, getRelationshipTo, deleteRelationship, getRelationships, + -- * Properties + setProperties, setProperty, deleteProperties, deleteProperty, + -- * Labels + getLabels, getNodesByLabelAndProperty, addLabels, changeLabels, removeLabel + )where + +import Database.Neo4j.Batch.Label +import Database.Neo4j.Batch.Node +import Database.Neo4j.Batch.Property +import Database.Neo4j.Batch.Relationship +import Database.Neo4j.Batch.Types + +-- $use +-- +-- With batch mode you can issue several commands to Neo4j at once. +-- In order to issue batches you must use the Batch monad, parameters in batch mode can be actual entities already +-- obtained by issuing regular commands or previous batch commands, or even batch futures, that is you can refer +-- to entities created in the same batch, for instance: +-- +-- > withConnection "127.0.0.1" 7474 $ do +-- > g <- B.runBatch $ do +-- > neo <- B.createNode M.empty +-- > cypher <- B.createNode M.empty +-- > B.createRelationship "KNOWS" M.empty neo cypher +-- > ... +-- +-- Batch commands return a "Database.Neo4j.Graph" object that holds all the information about relationships, +-- nodes and their labels that can be inferred from running a batch command. diff --git a/src/Database/Neo4j/Batch/Label.hs b/src/Database/Neo4j/Batch/Label.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Batch/Label.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Neo4j.Batch.Label where + +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Network.HTTP.Base (urlEncodeVars) + +import qualified Data.Aeson as J +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Network.HTTP.Types as HT + +import qualified Database.Neo4j.Graph as G + +import Database.Neo4j.Types +import Database.Neo4j.Batch.Node +import Database.Neo4j.Batch.Types + +parseLabelsPath :: J.Value -> T.Text -> NodeUrl +parseLabelsPath j suf = NodeUrl $ let p = tryParseFrom j in fromMaybe p $ T.stripSuffix suf p + +-- | Retrieve all labels for a node, if the node doesn't exist already it will raise an exception +-- | Raises Neo4jNoEntityException if the node doesn't exist +getLabels :: NodeBatchIdentifier a => a -> Batch (BatchFuture [Label]) +getLabels n = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodGet, cmdPath = path, cmdBody = "", cmdParse = parser} + path = getNodeBatchId n <> "/labels" + parser jn = G.setNodeLabels (parseLabelsPath jn "/labels") (tryParseBody jn) + +-- | Get all nodes using a label and a property +getNodesByLabelAndProperty :: Label -> Maybe (T.Text, PropertyValue) -> Batch (BatchFuture [Node]) +getNodesByLabelAndProperty lbl prop = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodGet, cmdPath = path, cmdBody = "", cmdParse = parser} + path = "/label/" <> lbl <> "/nodes" <> fromString (propUrl prop) + propUrl Nothing = "" + propUrl (Just (name, value)) = '?' : urlEncodeVars [(T.unpack name, lbsToStr $ J.encode value)] + lbsToStr = S.unpack . L.toStrict + parser jn g = foldl (\gacc n -> G.addNodeLabel n lbl (G.addNode n gacc)) g (tryParseBody jn) + +-- | Add labels to a node +-- | Raises Neo4jNoEntityException if the node doesn't exist +addLabels :: NodeBatchIdentifier a => [Label] -> a -> Batch (BatchFuture ()) +addLabels lbls n = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodPost, cmdPath = path, cmdBody = J.toJSON lbls, cmdParse = parser} + path = getNodeBatchId n <> "/labels" + parser jn g = let from = parseLabelsPath jn "/labels" in foldl (flip (G.addNodeLabel from)) g lbls + +-- | Change node labels +-- | Raises Neo4jNoEntityException if the node doesn't exist +changeLabels :: NodeBatchIdentifier a => [Label] -> a -> Batch (BatchFuture ()) +changeLabels lbls n = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodPut, cmdPath = path, cmdBody = J.toJSON lbls, cmdParse = parser} + path = getNodeBatchId n <> "/labels" + parser jn = G.setNodeLabels (parseLabelsPath jn "/labels") lbls + +-- | Remove a label for a node +-- | Raises Neo4jNoEntityException if the node doesn't exist +removeLabel :: NodeBatchIdentifier a => Label -> a -> Batch (BatchFuture ()) +removeLabel lbl n = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodDelete, cmdPath = path, cmdBody = "", cmdParse = parser} + suffix = "/labels/" <> lbl + path = getNodeBatchId n <> suffix + parser jn = G.deleteNodeLabel (parseLabelsPath jn suffix) lbl diff --git a/src/Database/Neo4j/Batch/Node.hs b/src/Database/Neo4j/Batch/Node.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Batch/Node.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Neo4j.Batch.Node where + +import Data.String (fromString) + +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified Network.HTTP.Types as HT + +import qualified Database.Neo4j.Graph as G + +import Database.Neo4j.Batch.Types +import Database.Neo4j.Types + +class NodeBatchIdentifier a where + getNodeBatchId :: a -> T.Text + +instance NodeBatchIdentifier Node where + getNodeBatchId = urlMinPath . runNodeUrl . nodeUrl + +instance NodeBatchIdentifier NodeUrl where + getNodeBatchId = urlMinPath . runNodeUrl + +instance NodeBatchIdentifier NodePath where + getNodeBatchId = urlMinPath . runNodePath + +instance NodeBatchIdentifier (BatchFuture Node) where + getNodeBatchId (BatchFuture bId) = "{" <> (fromString . show) bId <> "}" + +-- | Batch operation to create a node +createNode :: Properties -> Batch (BatchFuture Node) +createNode props = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodPost, cmdPath = "/node", cmdBody = J.toJSON props, cmdParse = parser} + parser n = G.addNode (tryParseBody n) + +-- | Batch operation to get a node from the DB +getNode :: NodeBatchIdentifier a => a -> Batch (BatchFuture Node) +getNode n = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodGet, cmdPath = getNodeBatchId n, cmdBody = "", cmdParse = parser} + parser jn = G.addNode (tryParseBody jn) + +-- | Batch operation to delete a node +deleteNode :: NodeBatchIdentifier a => a -> Batch (BatchFuture ()) +deleteNode n = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodDelete, cmdPath = getNodeBatchId n, cmdBody = "", cmdParse = parser} + parser f = G.deleteNode (NodeUrl $ tryParseFrom f) diff --git a/src/Database/Neo4j/Batch/Property.hs b/src/Database/Neo4j/Batch/Property.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Batch/Property.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Neo4j.Batch.Property where + +import Data.Maybe (fromMaybe) + +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified Network.HTTP.Types as HT + +import qualified Database.Neo4j.Graph as G + +import Database.Neo4j.Types +import Database.Neo4j.Batch.Node +import Database.Neo4j.Batch.Relationship +import Database.Neo4j.Batch.Types + +class BatchEntity a where + getEntityBatchId :: a -> T.Text + +instance BatchEntity Node where + getEntityBatchId = getNodeBatchId + +instance BatchEntity NodeUrl where + getEntityBatchId = getNodeBatchId + +instance BatchEntity NodePath where + getEntityBatchId = getNodeBatchId + +instance BatchEntity (BatchFuture Node) where + getEntityBatchId = getNodeBatchId + +instance BatchEntity Relationship where + getEntityBatchId = getRelBatchId + +instance BatchEntity RelUrl where + getEntityBatchId = getRelBatchId + +instance BatchEntity RelPath where + getEntityBatchId = getRelBatchId + +instance BatchEntity (BatchFuture Relationship) where + getEntityBatchId = getRelBatchId + +parsePropertiesPath :: J.Value -> T.Text -> T.Text +parsePropertiesPath j suf = let p = tryParseFrom j in fromMaybe p $ T.stripSuffix suf p + +-- | Set all relationship/node properties +setProperties :: BatchEntity a => a -> Properties -> Batch (BatchFuture ()) +setProperties e props = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodPut, cmdPath = path, cmdBody = J.toJSON props, cmdParse = parser} + path = getEntityBatchId e <> "/properties" + parser f = G.setProperties (parsePropertiesPath f "/properties") props + +-- | Set a relationship/node property +setProperty :: BatchEntity a => a -> T.Text -> PropertyValue -> Batch (BatchFuture ()) +setProperty e name value = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodPut, cmdPath = path, cmdBody = J.toJSON value, cmdParse = parser} + path = getEntityBatchId e <> pathsuffix + pathsuffix = "/properties/" <> name + parser :: J.Value -> G.Graph -> G.Graph + parser f = G.setProperty (parsePropertiesPath f pathsuffix) name value + +-- | Delete all relationship/node properties +deleteProperties :: BatchEntity a => a -> Batch (BatchFuture ()) +deleteProperties e = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodDelete, cmdPath = path, cmdBody = "", cmdParse = parser} + path = getEntityBatchId e <> "/properties" + parser f = G.deleteProperties (parsePropertiesPath f "/properties") + +-- | Delete a relationship/node property +deleteProperty :: BatchEntity a => a -> T.Text -> Batch (BatchFuture ()) +deleteProperty e key = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodDelete, cmdPath = path, cmdBody = "", cmdParse = parser} + path = getEntityBatchId e <> pathsuffix + pathsuffix = "/properties/" <> key + parser f = G.deleteProperty (parsePropertiesPath f pathsuffix) key diff --git a/src/Database/Neo4j/Batch/Relationship.hs b/src/Database/Neo4j/Batch/Relationship.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Batch/Relationship.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Neo4j.Batch.Relationship where + +import Data.Aeson ((.=)) +import Data.String (fromString) + +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified Network.HTTP.Types as HT + +import qualified Database.Neo4j.Graph as G + +import Database.Neo4j.Types +import Database.Neo4j.Batch.Node +import Database.Neo4j.Batch.Types + +class RelBatchIdentifier a where + getRelBatchId :: a -> T.Text + +instance RelBatchIdentifier Relationship where + getRelBatchId = urlMinPath . runRelUrl . relUrl + +instance RelBatchIdentifier RelUrl where + getRelBatchId = urlMinPath . runRelUrl + +instance RelBatchIdentifier RelPath where + getRelBatchId = urlMinPath . runRelPath + +instance RelBatchIdentifier (BatchFuture Relationship) where + getRelBatchId (BatchFuture bId) = "{" <> (fromString . show) bId <> "}" + +-- | Create a new relationship with a type and a set of properties +createRelationship :: (NodeBatchIdentifier a, NodeBatchIdentifier b) => RelationshipType -> Properties -> a -> b -> + Batch (BatchFuture Relationship) +createRelationship t props nodefrom nodeto = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodPost, cmdPath = path, cmdBody = J.toJSON body, cmdParse = parser} + path = getNodeBatchId nodefrom <> "/relationships" + body = J.object ["to" .= getNodeBatchId nodeto, "type" .= t, "data" .= J.toJSON props] + parser r = G.addRelationship (tryParseBody r) + +-- | Refresh a relationship entity with the contents in the DB +getRelationship :: RelBatchIdentifier r => r -> Batch (BatchFuture Relationship) +getRelationship rel = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodGet, cmdPath = getRelBatchId rel, cmdBody = "", cmdParse = parser} + parser jr = G.addRelationship (tryParseBody jr) + +-- | Get the "node from" from a relationship from the DB +getRelationshipFrom :: Relationship -> Batch (BatchFuture Node) +getRelationshipFrom rel = getNode $ relFrom rel + +-- | Get the "node to" from a relationship from the DB +getRelationshipTo :: Relationship -> Batch (BatchFuture Node) +getRelationshipTo rel = getNode $ relTo rel + +-- | Delete a relationship +deleteRelationship :: RelBatchIdentifier r => r -> Batch (BatchFuture ()) +deleteRelationship rel = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodDelete, cmdPath = getRelBatchId rel, cmdBody = "", cmdParse = parser} + parser jr = G.deleteRelationship (RelUrl $ tryParseFrom jr) + +-- | Get all relationships for a node +getRelationships :: NodeBatchIdentifier n => n -> Direction -> [RelationshipType] -> Batch (BatchFuture [Relationship]) +getRelationships n dir types = nextState cmd + where cmd = defCmd{cmdMethod = HT.methodGet, cmdPath = path, cmdBody = "", cmdParse = parser} + path = getNodeBatchId n <> "/relationships/" <> dirStr dir <> filterStr types + parser jr g = foldl (\gacc r -> G.addRelationship r gacc) g (tryParseBody jr) + dirStr Outgoing = "out" + dirStr Incoming = "in" + dirStr Any = "all" + filterStr [] = "" + filterStr f = "/" <> (T.intercalate "%26" f) diff --git a/src/Database/Neo4j/Graph.hs b/src/Database/Neo4j/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Graph.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Module to handle 'Graph' objects. These have information about a group of nodes, relationships, +-- and information about labels per node and nodes per label. +-- 'Graph' objects for now are returned by "Database.Neo4j.Batch" operations and in the future hopefully after +-- adding cypher support they will be part of their result +-- Notice a graph can have relationships and at the same time not have some of the nodes of those +-- relationships, see the section called handling orphaned relationships. This is so because commands in a batch +-- might retrieve relationships but might not create or retrieve their respective nodes. +module Database.Neo4j.Graph ( + -- * General objects + Graph, LabelSet, empty, + -- * Handling nodes in the graph object + addNode, hasNode, deleteNode, getNodes, + -- * Handling properties in the graph object + getRelationships, hasRelationship, addRelationship, deleteRelationship, getRelationshipNodeFrom, + getRelationshipNodeTo, + -- ** Handling orphaned relationships #orphan# + getOrphansFrom, getOrphansTo, cleanOrphanRelationships, + -- * Handling properties + setProperties, setProperty, deleteProperties, deleteProperty, + -- * Handling labels + setNodeLabels, addNodeLabel, getNodeLabels, deleteNodeLabel, + -- * Graph filtering functions + nodeFilter, relationshipFilter, + -- * Graph operations + union, difference, intersection + )where + +import Data.Maybe (fromMaybe) + +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as HS +import qualified Data.Text as T + +import Database.Neo4j.Types + +type NodeIndex = M.HashMap NodePath Node +type RelIndex = M.HashMap RelPath Relationship +type NodeSet = HS.HashSet NodePath +type LabelNodeIndex = M.HashMap Label NodeSet +type LabelSet = HS.HashSet Label +type NodeLabelIndex = M.HashMap NodePath LabelSet + +data Graph = Graph {nodes :: NodeIndex, labels :: LabelNodeIndex, rels :: RelIndex, + nodeLabels :: NodeLabelIndex} deriving (Eq, Show) + +-- | Create an empty graph +empty :: Graph +empty = Graph {nodes = M.empty, labels = M.empty, rels = M.empty, nodeLabels = M.empty} + +-- | Add a node to the graph +addNode :: Node -> Graph -> Graph +addNode n g = g {nodes = M.insert (getNodePath n) n (nodes g)} + +-- | Set the properties of a node or relationship in the graph, if not present it won't do anything +setProperties :: EntityIdentifier a => a -> Properties -> Graph -> Graph +setProperties ei props g = fromMaybe g $ entity >>= return . newEntity >>= return . addEntity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> M.lookup p (nodes g) >>= return . entityObj + (EntityRelPath p) -> M.lookup p (rels g) >>= return . entityObj + newEntity e = setEntityProperties e props + addEntity e = case e of + (EntityNode n) -> g{nodes = M.insert (getNodePath n) n (nodes g)} + (EntityRel r) -> g{rels = M.insert (getRelPath r) r (rels g)} + +-- | Set a property of a node or relationship in the graph, if not present it won't do anything +setProperty :: EntityIdentifier a => a -> T.Text -> PropertyValue -> Graph -> Graph +setProperty ei name value g = fromMaybe g $ entity >>= return . newEntity >>= return . addEntity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> M.lookup p (nodes g) >>= return . entityObj + (EntityRelPath p) -> M.lookup p (rels g) >>= return . entityObj + newEntity e = setEntityProperties e $ M.insert name value (getEntityProperties e) + addEntity e = case e of + (EntityNode n) -> g{nodes = M.insert (getNodePath n) n (nodes g)} + (EntityRel r) -> g{rels = M.insert (getRelPath r) r (rels g)} + +-- | Delete all the properties of a node or relationship, if the entity is not present it won't do anything +deleteProperties :: EntityIdentifier a => a -> Graph -> Graph +deleteProperties ei g = fromMaybe g $ entity >>= return . newEntity >>= return . addEntity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> M.lookup p (nodes g) >>= return . entityObj + (EntityRelPath p) -> M.lookup p (rels g) >>= return . entityObj + newEntity e = setEntityProperties e emptyProperties + addEntity e = case e of + (EntityNode n) -> g{nodes = M.insert (getNodePath n) n (nodes g)} + (EntityRel r) -> g{rels = M.insert (getRelPath r) r (rels g)} + +-- | Delete a property of a node or relationship, if the entity is not present it won't do anything +deleteProperty :: EntityIdentifier a => a -> T.Text -> Graph -> Graph +deleteProperty ei key g = fromMaybe g $ entity >>= return . newEntity >>= return . addEntity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> M.lookup p (nodes g) >>= return . entityObj + (EntityRelPath p) -> M.lookup p (rels g) >>= return . entityObj + newEntity e = setEntityProperties e $ M.delete key (getEntityProperties e) + addEntity e = case e of + (EntityNode n) -> g{nodes = M.insert (getNodePath n) n (nodes g)} + (EntityRel r) -> g{rels = M.insert (getRelPath r) r (rels g)} + +-- | Whether a node is present in the graph +hasNode :: NodeIdentifier a => a -> Graph -> Bool +hasNode n g = getNodePath n `M.member` nodes g + +-- | Get a list with all the nodes in the graph +getNodes :: Graph -> [Node] +getNodes g = M.elems $ nodes g + +-- | Whether a node is present in the graph +hasRelationship :: RelIdentifier a => a -> Graph -> Bool +hasRelationship r g = getRelPath r `M.member` rels g + +-- | Delete a node from the graph +deleteNode :: NodeIdentifier a => a -> Graph -> Graph +deleteNode n g = g {nodes = M.delete nodeLoc (nodes g), + labels = cleanLabelNodeIndex $ removeNodeFromLabels (labels g) labelsForNode, + nodeLabels = M.delete nodeLoc (nodeLabels g)} + where labelsForNode = M.lookupDefault HS.empty nodeLoc (nodeLabels g) + nodeLoc = getNodePath n + removeNodeFromLabels = HS.foldl' (\acc x -> M.insertWith (\_ -> HS.delete nodeLoc) x HS.empty acc) + cleanLabelNodeIndex = M.filter (/=HS.empty) + +-- | Add a relationship to the graph +addRelationship :: Relationship -> Graph -> Graph +addRelationship r g = g {rels = M.insert (getRelPath r) r (rels g)} + +-- | Get a list with all the relationships in the graph +getRelationships :: Graph -> [Relationship] +getRelationships g = M.elems $ rels g + +-- | Get relationships missing their "from" node +getOrphansFrom :: Graph -> [Relationship] +getOrphansFrom g = M.elems $ M.filter noNode (rels g) + where noNode r = not $ getNodePath (relFrom r) `M.member` nodes g + +-- | Get relationships missing their "to" node +getOrphansTo :: Graph -> [Relationship] +getOrphansTo g = M.elems $ M.filter noNode (rels g) + where noNode r = not $ getNodePath (relTo r) `M.member` nodes g + +-- | Remove all relationships with a missing node +cleanOrphanRelationships :: Graph -> Graph +cleanOrphanRelationships g = foldl (flip deleteRelationship) g (getOrphansFrom g ++ getOrphansTo g) + +-- | Delete a relationship from the graph +deleteRelationship :: RelIdentifier a => a -> Graph -> Graph +deleteRelationship r g = g {rels = M.delete (getRelPath r) (rels g)} + +-- | Get the "node from" from a relationship +getRelationshipNodeFrom :: Relationship -> Graph -> Maybe Node +getRelationshipNodeFrom r g = M.lookup (getNodePath (relFrom r)) (nodes g) + +-- | Get the "node to" from a relationship +getRelationshipNodeTo :: Relationship -> Graph -> Maybe Node +getRelationshipNodeTo r g = M.lookup (getNodePath (relTo r)) (nodes g) + +-- | Set what labels a node has +setNodeLabels :: NodeIdentifier a => a -> [Label] -> Graph -> Graph +setNodeLabels n lbls g = g {nodeLabels = M.insert (getNodePath n) (HS.fromList lbls) (nodeLabels g), + labels = insertLabels lbls (labels g)} + where insertLabels xs acc = foldl (\accum x -> M.insertWith HS.union x defaultNodeSet accum) acc xs + defaultNodeSet = HS.singleton $ getNodePath n + +-- | Add a label to a node +addNodeLabel :: NodeIdentifier a => a -> Label -> Graph -> Graph +addNodeLabel n lbl g = g {nodeLabels = M.insertWith HS.union locationForNode (HS.singleton lbl) nodeLabelIndex, + labels = M.insertWith HS.union lbl (HS.singleton locationForNode) labelNodeIndex} + where locationForNode = getNodePath n + nodeLabelIndex = nodeLabels g + labelNodeIndex = labels g + +-- | Get the labels of a node +getNodeLabels :: NodeIdentifier a => a -> Graph -> LabelSet +getNodeLabels n g = let loc = getNodePath n in M.lookupDefault HS.empty loc (nodeLabels g) + +-- | Remove a label from a node +deleteNodeLabel :: NodeIdentifier a => a -> Label -> Graph -> Graph +deleteNodeLabel n lbl g = g {nodeLabels = M.insertWith nodeLabelIndexOp locationForNode HS.empty nodeLabelIndex, + labels = M.insertWith labelNodeIndexOp lbl HS.empty labelNodeIndex} + where locationForNode = getNodePath n + nodeLabelIndex = nodeLabels g + nodeLabelIndexOp = const $ HS.delete lbl + labelNodeIndex = labels g + labelNodeIndexOp = const $ HS.delete locationForNode + + +-- | Filter the nodes of a graph +nodeFilter :: (Node -> Bool) -> Graph -> Graph +nodeFilter f g = foldl (\gacc n -> if f n then deleteNode n gacc else gacc) g (M.elems $ nodes g) + +-- | Filter the relationships of a graph +relationshipFilter :: (Relationship -> Bool) -> Graph -> Graph +relationshipFilter f g = foldl (\gacc r -> if f r then deleteRelationship r gacc else gacc) g (M.elems $ rels g) + +-- | Add two graphs resulting in a graph with all the nodes, labels and relationships of both +-- | If a node/entity is present in both the second one will be chosen +union :: Graph -> Graph -> Graph +union ga gb = addRels ga (addNodes ga gb) + where addRels g1 g2 = foldl (flip addRelationship) g1 (M.elems $ rels g2) + addNodes g1 g2 = foldl (flip addNode) g1 (M.elems $ nodes g2) + +-- | Remove the nodes and relationships in the first graph that appear in the second +difference :: Graph -> Graph -> Graph +difference ga gb = relationshipFilter relFilterFunc (nodeFilter nodeFilterFunc ga) + where relFilterFunc r = not $ hasRelationship r gb + nodeFilterFunc n = not $ hasNode n gb + +-- | Have a graph that only has nodes and relationships that are present in both +intersection :: Graph -> Graph -> Graph +intersection ga gb = relationshipFilter relFilterFunc (nodeFilter nodeFilterFunc ga) + where relFilterFunc r = hasRelationship r gb + nodeFilterFunc n = hasNode n gb diff --git a/src/Database/Neo4j/Http.hs b/src/Database/Neo4j/Http.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Http.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Neo4j.Http where + +import Control.Exception.Base (Exception, throw, catch, toException) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (runResourceT, ResourceT) +import Data.Default (def) +import Data.Maybe (fromMaybe) + +import Data.Aeson ((.:)) +import Data.Aeson.Types (parseMaybe) + +import qualified Data.Aeson as J +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Network.HTTP.Conduit as HC +import qualified Network.HTTP.Types as HT + +import Database.Neo4j.Types + + +-- | Create a new connection that can be manually closed with runResourceT +newConnection :: Hostname -> Port -> ResourceT IO Connection +newConnection hostname port = do + mgr <- liftIO $ HC.newManager HC.conduitManagerSettings + return $ Connection hostname port mgr + +-- | Run a set of Neo4j commands in a single connection +withConnection :: Hostname -> Port -> Neo4j a -> IO a +withConnection hostname port cmds = runResourceT $ do + conn <- newConnection hostname port + runNeo4j cmds conn + +-- | General function for HTTP requests +httpReq :: Connection -> HT.Method -> S.ByteString -> L.ByteString -> (HT.Status -> Bool) -> + ResourceT IO (HC.Response L.ByteString) +httpReq (Connection h p m) method path body statusCheck = do + let request = def { + HC.host = h, + HC.port = p, + HC.path = path, + HC.method = method, + HC.requestBody = HC.RequestBodyLBS body, + HC.checkStatus = \s _ _ -> if statusCheck s + then Nothing + else Just (toException $ Neo4jUnexpectedResponseException s), + HC.requestHeaders = [(HT.hAccept, "application/json; charset=UTF-8"), + (HT.hContentType, "application/json")]} + -- TODO: Would be better to use exceptions package Control.Monad.Catch ?? + -- Wrapping up HTTP-Conduit exceptions in our own + liftIO $ HC.httpLbs request m `catch` wrapException + where wrapException :: HC.HttpException -> a + wrapException = throw . Neo4jHttpException . show + +-- | Extracts the exception description from a HTTP Neo4j response if the status code matches otherwise Nothing +extractException :: HC.Response L.ByteString -> T.Text +extractException resp = fromMaybe "" $ do + resobj <- J.decode $ HC.responseBody resp + flip parseMaybe resobj $ \obj -> obj .: "exception" + +-- | Launch a POST request, this will raise an exception if 201 or 204 is not received +httpCreate :: J.FromJSON a => Connection -> S.ByteString -> L.ByteString -> ResourceT IO a +httpCreate conn path body = do + res <- httpReq conn HT.methodPost path body (`elem` [HT.status200, HT.status201]) + let resBody = J.eitherDecode $ HC.responseBody res + return $ case resBody of + Right entity -> entity + Left e -> throw $ Neo4jParseException ("Error parsing created entity: " ++ e) + +-- | Launch a POST request, this will raise an exception if 201 or 204 is not received, explain 500 +httpCreate500Explained :: J.FromJSON a => Connection -> S.ByteString -> L.ByteString -> + ResourceT IO (Either L.ByteString a) +httpCreate500Explained conn path body = do + res <- httpReq conn HT.methodPost path body (`elem` [HT.status200, HT.status201, HT.status500]) + let status = HC.responseStatus res + let resBody = HC.responseBody res + return $ if status == HT.status500 then Left resBody else parseBody resBody + where parseBody b = case J.eitherDecode b of + Right entity -> Right entity + Left e -> throw $ Neo4jParseException ("Error parsing created entity: " ++ e) + +-- | Launch a POST request, this will raise an exception if 201 or 204 is not received +-- With 404 or 400 will return a left with the explanation +httpCreate4XXExplained :: J.FromJSON a => Connection -> S.ByteString -> L.ByteString -> ResourceT IO (Either T.Text a) +httpCreate4XXExplained conn path body = do + res <- httpReq conn HT.methodPost path body (\s -> s `elem` [HT.status201, HT.status404, HT.status400]) + let status = HC.responseStatus res + return $ if status == HT.status201 then parseBody res else Left $ extractException res + where parseBody resp = case J.eitherDecode $ HC.responseBody resp of + Right entity -> Right entity + Left e -> throw $ Neo4jParseException ("Error parsing created entity: " ++ e) + +-- | Launch a POST request that doesn't expect response body, this will raise an exception if 204 is not received +httpCreate_ :: Connection -> S.ByteString -> L.ByteString -> ResourceT IO () +httpCreate_ conn path body = do + _ <- httpReq conn HT.methodPost path body (\s -> s == HT.status201 || s == HT.status204) + return () + +-- | Launch a GET request, this will raise an exception if 200 or 404 is not received +httpRetrieve :: J.FromJSON a => Connection -> S.ByteString -> ResourceT IO (Maybe a) +httpRetrieve conn path = do + res <- httpReq conn HT.methodGet path "" (\s -> s == HT.status200 || s == HT.status404) + let status = HC.responseStatus res + let body = if status == HT.status200 + then Just $ J.eitherDecode $ HC.responseBody res + else Nothing + return $ case body of + Just (Right entity) -> Just entity + Just (Left e) -> throw $ Neo4jParseException ("Error parsing received entity: " ++ e) + Nothing -> Nothing + +-- | Launch GET request, just allow 200, if 404 is received an exception will be raised +httpRetrieveSure :: J.FromJSON a => Connection -> S.ByteString -> ResourceT IO a +httpRetrieveSure conn path = do + res <- httpReq conn HT.methodGet path "" (==HT.status200) + let body = J.eitherDecode $ HC.responseBody res + return $ case body of + Right entity -> entity + Left e -> throw $ Neo4jParseException ("Error parsing received entity: " ++ e) + +-- | Launch a GET request, this will raise an exception if 200 or 404 is not received +-- With 404 will return a left with the explanation +-- Unlike httpRetrieve this method can parse any JSON value even if it's non-top (arrays and objects) +httpRetrieveValue :: J.FromJSON a => Connection -> S.ByteString -> ResourceT IO (Either T.Text a) +httpRetrieveValue conn path = do + res <- httpReq conn HT.methodGet path "" (\s -> s == HT.status200 || s == HT.status404) + let status = HC.responseStatus res + return $ if status == HT.status200 then parseBody res else Left $ extractException res + -- Ugly hack to parse values that aren't top level JSON values (objects and arrays) + where parseBody resp = case J.eitherDecode $ "[" `L.append` HC.responseBody resp `L.append` "]" of + Right (entity:[]) -> Right entity + Right _ -> throw $ Neo4jParseException "Error parsing received entity" + Left e -> throw $ Neo4jParseException ("Error parsing received entity: " ++ e) + + +-- | Launch a DELETE request, this will raise an exception if 204 is not received +-- If we receive 404, we will just return true, though wasn't existing already the result is the same +httpDelete :: Connection -> S.ByteString -> ResourceT IO () +httpDelete c pth = do + _ <- httpReq c HT.methodDelete pth "" (\s -> s == HT.status204 || s == HT.status404) + return () + +-- | Launch a DELETE request, this will raise an exception if 204 is not received +-- We don't accept 404 +httpDeleteNo404 :: Connection -> S.ByteString -> ResourceT IO () +httpDeleteNo404 c pth = do + _ <- httpReq c HT.methodDelete pth "" (==HT.status204) + return () + +-- | Launch a DELETE request, this will raise an exception if 204 is not received +-- If we receive 404, we will return the server explanation +httpDelete404Explained :: Connection -> S.ByteString -> ResourceT IO (Either T.Text ()) +httpDelete404Explained c pth = do + res <- httpReq c HT.methodDelete pth "" (\s -> s == HT.status204 || s == HT.status404) + let status = HC.responseStatus res + return $ if status /= HT.status404 then Right () else Left $ extractException res + +-- | Launch a PUT request, this will raise an exception if 200 or 204 is not received +httpModify :: Connection -> S.ByteString -> L.ByteString -> ResourceT IO () +httpModify c path body = do + _ <- httpReq c HT.methodPut path body (\s -> s == HT.status200 || s == HT.status204) + return () + +-- | Launch a PUT request, this will raise an exception if 200 or 204 is not received +-- If we receive 404, we will return the server explanation +httpModify404Explained :: Connection -> S.ByteString -> L.ByteString -> ResourceT IO (Either T.Text ()) +httpModify404Explained c path body = do + res <- httpReq c HT.methodPut path body (\s -> s == HT.status200 || s == HT.status204 || s == HT.status404) + let status = HC.responseStatus res + return $ if status /= HT.status404 then Right () else Left $ extractException res + +-- | Wrap 404 exception into Neo4jNoEntity exceptions +proc404Exc :: Entity e => e -> Neo4jException -> a +proc404Exc e exc@(Neo4jUnexpectedResponseException s) + | s == HT.status404 = throw (Neo4jNoEntityException $ entityPath e) + | otherwise = throw exc +proc404Exc _ exc = throw exc + diff --git a/src/Database/Neo4j/Index.hs b/src/Database/Neo4j/Index.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Index.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Neo4j.Index where + +import Data.Aeson ((.=)) + +import qualified Data.Aeson as J +import qualified Data.ByteString.Char8 as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Database.Neo4j.Types +import Database.Neo4j.Http + + +indexPath :: Label -> Maybe T.Text -> S.ByteString +indexPath lbl prop = "/db/data/schema/index/" <> TE.encodeUtf8 lbl <> propPath prop + where propPath (Just name) = "/" <> TE.encodeUtf8 name + propPath Nothing = "" + +-- | Creates an index for a label and a property +createIndex :: Label -> T.Text -> Neo4j Index +createIndex lbl prop = Neo4j $ \conn -> httpCreate conn (indexPath lbl Nothing) body + where body = J.encode $ J.object ["property_keys" .= [prop]] + +-- | Gets all indexes for a label +getIndexes :: Label -> Neo4j [Index] +getIndexes lbl = Neo4j $ \conn -> httpRetrieveSure conn (indexPath lbl Nothing) + +-- | Drop and index +dropIndex :: Label -> T.Text -> Neo4j () +dropIndex lbl prop = Neo4j $ \conn -> httpDelete conn (indexPath lbl (Just prop)) diff --git a/src/Database/Neo4j/Label.hs b/src/Database/Neo4j/Label.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Label.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Neo4j.Label where + +import Network.HTTP.Base (urlEncodeVars) +import Control.Exception.Lifted (catch) + +import qualified Data.Aeson as J +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Database.Neo4j.Types +import Database.Neo4j.Http + + +-- | Get all labels in the DB +allLabels :: Neo4j [Label] +allLabels = Neo4j $ \conn -> httpRetrieveSure conn "/db/data/labels" + +-- | Retrieve all labels for a node, if the node doesn't exist already it will raise an exception +-- | Raises Neo4jNoEntityException if the node doesn't exist +getLabels :: Node -> Neo4j [Label] +getLabels n = Neo4j $ \conn -> httpRetrieveSure conn (runNodeIdentifier n <> "/labels") `catch` proc404Exc n + +-- | Get all nodes using a label and a property +getNodesByLabelAndProperty :: Label -> Maybe (T.Text, PropertyValue) -> Neo4j [Node] +getNodesByLabelAndProperty lbl prop = Neo4j $ \conn -> + httpRetrieveSure conn ("/db/data/label/" <> TE.encodeUtf8 lbl <> "/nodes" <> propUrl prop) + where propUrl Nothing = "" + propUrl (Just (name, value)) = S.pack $ '?' : urlEncodeVars [(T.unpack name, lbsToStr $ J.encode value)] + lbsToStr = S.unpack . L.toStrict + +-- | Add labels to a node +-- | Raises Neo4jNoEntityException if the node doesn't exist +addLabels :: [Label] -> Node -> Neo4j () +addLabels lbls n = Neo4j $ \conn -> (do + httpCreate_ conn (runNodeIdentifier n <> "/labels") (J.encode lbls) + return ()) `catch` proc404Exc n + +-- | Change node labels +-- | Raises Neo4jNoEntityException if the node doesn't exist +changeLabels :: [Label] -> Node -> Neo4j () +changeLabels lbls n = Neo4j $ \conn -> + httpModify conn (runNodeIdentifier n <> "/labels") (J.encode lbls) `catch` proc404Exc n + +-- | Remove a label for a node +-- | Raises Neo4jNoEntityException if the node doesn't exist +removeLabel :: Label -> Node -> Neo4j () +removeLabel lbl n = Neo4j $ \conn -> (do + _ <- httpDeleteNo404 conn (runNodeIdentifier n <> "/labels/" <> TE.encodeUtf8 lbl) + return ()) `catch` proc404Exc n diff --git a/src/Database/Neo4j/Node.hs b/src/Database/Neo4j/Node.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Node.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Neo4j.Node where + +import Control.Exception.Lifted (throw, catch) + +import qualified Data.Aeson as J +import qualified Data.ByteString as S +import qualified Network.HTTP.Types as HT + +import Database.Neo4j.Types +import Database.Neo4j.Http + + +-- | Get the ID of a node +nodeId :: Node -> S.ByteString +nodeId n = S.drop (pathLength + 1) (runNodeIdentifier n) + where pathLength = S.length nodeAPI + +-- | Create a new node with a set of properties +createNode :: Properties -> Neo4j Node +createNode props = Neo4j $ \conn -> httpCreate conn nodeAPI (J.encode props) + +-- | Refresh a node entity with the contents in the DB +getNode :: NodeIdentifier a => a -> Neo4j (Maybe Node) +getNode n = Neo4j $ \conn -> httpRetrieve conn (runNodeIdentifier n) + +-- | Delete a node, if the node has relationships it will raise a Neo4jNonOrphanNodeDeletion +deleteNode :: NodeIdentifier a => a -> Neo4j () +deleteNode n = Neo4j $ \conn -> httpDelete conn (runNodeIdentifier n) `catch` processConflict + where processConflict e@(Neo4jUnexpectedResponseException s) + | s == HT.status409 = throw (Neo4jNonOrphanNodeDeletionException $ runNodeIdentifier n) + | otherwise = throw e + processConflict e = throw e diff --git a/src/Database/Neo4j/Property.hs b/src/Database/Neo4j/Property.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Property.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Neo4j.Property where + +import Control.Exception.Lifted (throw, catch) + +import qualified Data.Aeson as J +import qualified Data.HashMap.Lazy as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Database.Neo4j.Types +import Database.Neo4j.Http + + +-- | Retrieve relationship/node properties from the DB, if the entity is not present it will raise an exception +-- If the entity doesn't exist it will raise a Neo4jNoEntity exception +getProperties :: Entity a => a -> Neo4j Properties +getProperties e = Neo4j $ \conn -> httpRetrieveSure conn (propertyPath e) `catch` proc404Exc e + +-- | Get a relationship/node property +-- If the 404 is because the parent entity doesn't exist we'll raise the corresponding Neo4jNoEntity +-- If the 404 is because there is no property just return Nothing +getProperty :: Entity a => a -> T.Text -> Neo4j (Maybe PropertyValue) +getProperty e prop = Neo4j $ \conn -> do + res <- httpRetrieveValue conn path + case res of + Right value -> return value + Left expl -> if expl `elem` excList then throw (Neo4jNoEntityException $ entityPath e) + else return Nothing + where path = propertyPath e <> "/" <> TE.encodeUtf8 prop + excList = ["RelationshipNotFoundException", "NodeNotFoundException"] + +-- | Set all relationship/node properties +-- If the entity doesn't exist it will raise a Neo4jNoEntity exception +setProperties :: Entity a => a -> Properties -> Neo4j a +setProperties e props = Neo4j $ \conn -> (do + httpModify conn (propertyPath e) $ J.encode props + return $ setEntityProperties e props) `catch` proc404Exc e + +-- | Set a relationship/node property +-- If the entity doesn't exist it will raise a Neo4jNoEntity exception +setProperty :: Entity a => a -> T.Text -> PropertyValue -> Neo4j a +setProperty e name value = Neo4j $ \conn -> (do + httpModify conn (propertyPath e <> "/" <> TE.encodeUtf8 name) $ J.encode value + return $ setEntityProperties e $ M.insert name value (getEntityProperties e)) `catch` proc404Exc e + +-- | Delete all relationship/node properties +-- If the entity doesn't exist it will raise a Neo4jNoEntity exception +deleteProperties :: Entity a => a -> Neo4j a +deleteProperties e = Neo4j $ \conn -> (do + httpDeleteNo404 conn (propertyPath e) + return $ setEntityProperties e emptyProperties) `catch` proc404Exc e + +-- | Delete a relationship/node property +-- If the entity doesn't exist it will raise a Neo4jNoEntity exception +deleteProperty :: Entity a => a -> T.Text -> Neo4j a +deleteProperty e name = Neo4j $ \conn -> do + res <- httpDelete404Explained conn (propertyPath e <> "/" <> TE.encodeUtf8 name) + case res of + Right _ -> return resultingProps + Left expl -> if expl `elem` excList then throw (Neo4jNoEntityException $ entityPath e) + else return resultingProps + where excList = ["RelationshipNotFoundException", "NodeNotFoundException"] + resultingProps = setEntityProperties e $ M.delete name (getEntityProperties e) + diff --git a/src/Database/Neo4j/Relationship.hs b/src/Database/Neo4j/Relationship.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Relationship.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Neo4j.Relationship where + + +import Control.Exception.Lifted (throw, catch) +import Data.Aeson ((.=)) +import Data.Maybe (fromMaybe) + +import qualified Data.Aeson as J +import qualified Data.ByteString as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Types as HT + +import Database.Neo4j.Node +import Database.Neo4j.Http +import Database.Neo4j.Types + + +-- | Get the ID of a relationship +relId :: Relationship -> S.ByteString +relId n = S.drop (pathLength + 1) (runRelIdentifier n) + where pathLength = S.length relationshipAPI + +-- | Gets all relationship types in the DB +allRelationshipTypes :: Neo4j [RelationshipType] +allRelationshipTypes = Neo4j $ \conn -> httpRetrieveSure conn "/db/data/relationship/types" + +-- | Create a new relationship with a type and a set of properties +createRelationship :: RelationshipType -> Properties -> Node -> Node -> Neo4j Relationship +createRelationship t props nodefrom nodeto = Neo4j $ \conn -> do + res <- httpCreate4XXExplained conn reqPath reqBody + case res of + Right rel -> return rel + Left expl -> wrapExc expl + where reqPath = runNodeIdentifier nodefrom <> "/relationships" + reqBody = J.encode $ J.object ["to" .= runNodeUrl (nodeUrl nodeto), "type" .= t, + "data" .= J.toJSON props] + wrapExc msg + | msg == "StartNodeNotFoundException" = throw (Neo4jNoEntityException $ runNodeIdentifier nodefrom) + | msg == "EndNodeNotFoundException" = throw (Neo4jNoEntityException $ runNodeIdentifier nodeto) + | otherwise = throw (Neo4jHttpException $ T.unpack msg) + +-- | Refresh a relationship entity with the contents in the DB +getRelationship :: RelIdentifier a => a -> Neo4j (Maybe Relationship) +getRelationship rel = Neo4j $ \conn -> httpRetrieve conn (runRelIdentifier rel) + +-- | Get the "node from" from a relationship from the DB +-- | Raises Neo4jNoEntityException if the node (and thus the relationship) does not exist any more +getRelationshipFrom :: Relationship -> Neo4j Node +getRelationshipFrom rel = getNode node >>= processMaybe + where node = relFrom rel + processMaybe n = return $ fromMaybe (throw $ Neo4jNoEntityException (runNodeIdentifier node)) n + +-- | Get the "node to" from a relationship from the DB +-- | Raises Neo4jNoEntityException if the node (and thus the relationship) does not exist any more +getRelationshipTo :: Relationship -> Neo4j Node +getRelationshipTo rel = getNode node >>= processMaybe + where node = relTo rel + processMaybe n = return $ fromMaybe (throw $ Neo4jNoEntityException (runNodeIdentifier node)) n + +-- | Delete a relationship +deleteRelationship :: RelIdentifier a => a -> Neo4j () +deleteRelationship rel = Neo4j $ \conn -> httpDelete conn (runRelIdentifier rel) + +-- | Get all relationships for a node, if the node has disappeared it will raise an exception +getRelationships :: Node -> Direction -> [RelationshipType] -> Neo4j [Relationship] +getRelationships n dir types = Neo4j $ \conn -> + httpRetrieveSure conn (runNodeIdentifier n <> "/relationships/" <> dirStr dir <> filterStr types) `catch` procExc + where dirStr Outgoing = "out" + dirStr Incoming = "in" + dirStr Any = "all" + filterStr [] = "" + filterStr f = "/" <> TE.encodeUtf8 (T.intercalate "%26" f) + procExc exc@(Neo4jUnexpectedResponseException s) + | s == HT.status404 = throw (Neo4jNoEntityException $ runNodeIdentifier n) + | otherwise = throw exc + procExc exc = throw exc diff --git a/src/Database/Neo4j/Types.hs b/src/Database/Neo4j/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Types.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.Neo4j.Types where + +import Data.Hashable (Hashable) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid, mappend) +import Data.Typeable (Typeable) +import Control.Exception.Base (Exception) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (ResourceT) +import GHC.Generics (Generic) + +import Data.Aeson ((.:)) +import qualified Data.Aeson as J +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Lazy as M +import qualified Data.Scientific as Sci +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Network.HTTP.Conduit as HC +import qualified Network.HTTP.Types as HT + +(<>) :: (Monoid a) => a -> a -> a +(<>) = mappend + +-- | Type for a single value of a Neo4j property +data Val = IntVal Int64 | BoolVal Bool | TextVal T.Text | DoubleVal Double deriving (Show, Eq) + +-- | Wrapping type for a Neo4j single property or array of properties +-- Using these types allows type checking for only correct properties +-- that is int, double, string, boolean and single typed arrays of these, also nulls are not allowed +data PropertyValue = ValueProperty Val | ArrayProperty [Val] deriving (Show, Eq) + +-- | This class allows easy construction of property value types from literals +class PropertyValueConstructor a where + newval :: a -> PropertyValue + +instance PropertyValueConstructor Int64 where + newval v = ValueProperty $ IntVal v + +instance PropertyValueConstructor Bool where + newval v = ValueProperty $ BoolVal v + +instance PropertyValueConstructor T.Text where + newval v = ValueProperty $ TextVal v + +instance PropertyValueConstructor Double where + newval v = ValueProperty $ DoubleVal v + +instance PropertyValueConstructor [Int64] where + newval v = ArrayProperty $ map IntVal v + +instance PropertyValueConstructor [Bool] where + newval v = ArrayProperty $ map BoolVal v + +instance PropertyValueConstructor [T.Text] where + newval v = ArrayProperty $ map TextVal v + +instance PropertyValueConstructor [Double] where + newval v = ArrayProperty $ map DoubleVal v + +-- | This operator allows easy construction of property value types from literals +(|:) :: PropertyValueConstructor a => T.Text -> a -> (T.Text, PropertyValue) +name |: v = (name, newval v) + +-- | Specifying how to convert property single values to JSON +instance J.ToJSON Val where + toJSON (IntVal v) = J.Number $ fromIntegral v + toJSON (BoolVal v) = J.Bool v + toJSON (TextVal v) = J.String v + toJSON (DoubleVal v) = J.Number $ Sci.fromFloatDigits v + +-- | Specifying how to convert property values to JSON +instance J.ToJSON PropertyValue where + toJSON (ValueProperty v) = J.toJSON v + toJSON (ArrayProperty vs) = J.Array (V.fromList $ map J.toJSON vs) + +-- | JSON to single property values +instance J.FromJSON Val where + parseJSON (J.Number v) = let parsedNum = Sci.floatingOrInteger v in + return $ case parsedNum of + Left d -> DoubleVal d + Right i -> IntVal i + parseJSON (J.Bool v) = return $ BoolVal v + parseJSON (J.String v) = return $ TextVal v + parseJSON _ = mzero + +-- | JSON to property values +instance J.FromJSON PropertyValue where + parseJSON (J.Array v) = ArrayProperty <$> mapM J.parseJSON (V.toList v) + parseJSON v = ValueProperty <$> J.parseJSON v + +-- | We use hashmaps to represent Neo4j properties +type Properties = M.HashMap T.Text PropertyValue + +-- | Shortcut for emtpy properties +emptyProperties :: M.HashMap T.Text PropertyValue +emptyProperties = M.empty + +-- | Tries to get the path from a URL, we try our best otherwise return the url as is +urlPath :: T.Text -> T.Text +urlPath url = fromMaybe url $ T.stripPrefix "http://" url >>= return . T.dropWhile (/='/') + +-- | Path without the /db/data part, useful for batch paths and such +urlMinPath :: T.Text -> T.Text +urlMinPath url = fromMaybe url $ T.stripPrefix "/db/data" (urlPath url) + + +data EntityObj = EntityNode Node | EntityRel Relationship deriving (Eq, Show) + +-- | Class for top-level Neo4j entities (nodes and relationships) useful to have generic property management code +class Entity a where + entityPath :: a -> S.ByteString + propertyPath :: a -> S.ByteString + getEntityProperties :: a -> Properties + setEntityProperties :: a -> Properties -> a + entityObj :: a -> EntityObj + +-- | Get the path for a node entity without host and port +nodePath :: Node -> NodePath +nodePath = NodePath . urlPath . runNodeUrl . nodeUrl + +newtype NodeUrl = NodeUrl {runNodeUrl :: T.Text} deriving (Show, Eq, Generic) +instance Hashable NodeUrl + +-- | Representation of a Neo4j node, has a location URI and a set of properties +data Node = Node {nodeUrl :: NodeUrl, nodeProperties :: Properties} deriving (Show, Eq) + +-- | Get the properties of a node +getNodeProperties :: Node -> Properties +getNodeProperties = nodeProperties + +-- | JSON to Node +instance J.FromJSON Node where + parseJSON (J.Object v) = Node <$> (NodeUrl <$> (v .: "self")) <*> (v .: "data" >>= J.parseJSON) + parseJSON _ = mzero + +instance Entity Node where + entityPath = runNodeIdentifier + propertyPath n = runNodeIdentifier n <> "/properties" + getEntityProperties = nodeProperties + setEntityProperties n props = n {nodeProperties = props} + entityObj = EntityNode + +nodeAPI :: S.ByteString +nodeAPI = "/db/data/node" + +newtype NodePath = NodePath {runNodePath :: T.Text} deriving (Show, Eq, Generic) +instance Hashable NodePath + +class NodeIdentifier a where + getNodePath :: a -> NodePath + +instance NodeIdentifier Node where + getNodePath = nodePath + +instance NodeIdentifier S.ByteString where + getNodePath t = NodePath $ TE.decodeUtf8 $ nodeAPI <> "/" <> t + +instance NodeIdentifier NodePath where + getNodePath = id + +instance NodeIdentifier NodeUrl where + getNodePath n = NodePath $ (urlPath . runNodeUrl) n + +runNodeIdentifier :: NodeIdentifier a => a -> S.ByteString +runNodeIdentifier = TE.encodeUtf8 . runNodePath . getNodePath + +-- | Type for a relationship type description +type RelationshipType = T.Text + +-- | Relationship direction +data Direction = Outgoing | Incoming | Any + +-- | Get the path for a node entity without host and port +relPath :: Relationship -> RelPath +relPath = RelPath . urlPath . runRelUrl . relUrl + +-- | Type for a relationship location +newtype RelUrl = RelUrl {runRelUrl :: T.Text} deriving (Show, Eq, Generic) +instance Hashable RelUrl + +-- | Type for a Neo4j relationship, has a location URI, a relationship type, a starting node and a destination node +data Relationship = Relationship {relUrl :: RelUrl, + relType :: RelationshipType, + relProperties :: Properties, + relFrom :: NodeUrl, + relTo :: NodeUrl} deriving (Show, Eq) + +-- | Get the properties of a relationship +getRelProperties :: Relationship -> Properties +getRelProperties = relProperties + +-- | Get the type of a relationship +getRelType :: Relationship -> RelationshipType +getRelType = relType + +-- | JSON to Relationship +instance J.FromJSON Relationship where + parseJSON (J.Object v) = Relationship <$> (RelUrl <$> v .: "self") <*> v .: "type" <*> + (v .: "data" >>= J.parseJSON) <*> (NodeUrl <$> v .: "start") <*> + (NodeUrl <$> v .: "end") + parseJSON _ = mzero + +instance Entity Relationship where + entityPath = runRelIdentifier + propertyPath r = runRelIdentifier r <> "/properties" + getEntityProperties = relProperties + setEntityProperties r props = r {relProperties = props} + entityObj = EntityRel + +instance Entity EntityObj where + entityPath (EntityNode n) = runNodeIdentifier n + entityPath (EntityRel n) = runRelIdentifier n + propertyPath (EntityNode n) = runNodeIdentifier n <> "/properties" + propertyPath (EntityRel n) = runRelIdentifier n <> "/properties" + getEntityProperties (EntityNode n) = nodeProperties n + getEntityProperties (EntityRel n) = relProperties n + setEntityProperties (EntityNode n) props = EntityNode $ n {nodeProperties = props} + setEntityProperties (EntityRel n) props = EntityRel $ n {relProperties = props} + entityObj = id + +relationshipAPI :: S.ByteString +relationshipAPI = "/db/data/relationship" + +newtype RelPath = RelPath {runRelPath :: T.Text} deriving (Show, Eq, Generic) +instance Hashable RelPath + +class RelIdentifier a where + getRelPath :: a -> RelPath + +instance RelIdentifier Relationship where + getRelPath = relPath + +instance RelIdentifier RelPath where + getRelPath = id + +instance RelIdentifier S.ByteString where + getRelPath t = RelPath $ TE.decodeUtf8 $ relationshipAPI <> "/" <> t + +instance RelIdentifier RelUrl where + getRelPath = RelPath . urlPath . runRelUrl + +runRelIdentifier :: RelIdentifier a => a -> S.ByteString +runRelIdentifier = TE.encodeUtf8 . runRelPath . getRelPath + +data EntityPath = EntityRelPath RelPath | EntityNodePath NodePath deriving (Show, Eq) + +class EntityIdentifier a where + getEntityPath :: a -> EntityPath + +instance EntityIdentifier Node where + getEntityPath = EntityNodePath . getNodePath + +instance EntityIdentifier NodePath where + getEntityPath = EntityNodePath . getNodePath + +instance EntityIdentifier NodeUrl where + getEntityPath = EntityNodePath . getNodePath + +instance EntityIdentifier Relationship where + getEntityPath = EntityRelPath . getRelPath + +instance EntityIdentifier RelPath where + getEntityPath = EntityRelPath . getRelPath + +instance EntityIdentifier RelUrl where + getEntityPath = EntityRelPath . getRelPath + +instance EntityIdentifier T.Text where + getEntityPath i = (if T.count "/node" p > 0 then EntityNodePath . NodePath else EntityRelPath . RelPath) p + where p = urlPath i + +-- | Type for a label +type Label = T.Text + +-- | Type for an index +data Index = Index {indexLabel :: Label, indexProperties :: [T.Text]} deriving (Show, Eq) + +-- | JSON to Index +instance J.FromJSON Index where + parseJSON (J.Object v) = Index <$> v .: "label" <*> (v .: "property_keys" >>= J.parseJSON) + parseJSON _ = mzero + +-- | Exceptions this library can raise +data Neo4jException = Neo4jHttpException String | + Neo4jNonOrphanNodeDeletionException S.ByteString | + Neo4jNoEntityException S.ByteString | + Neo4jUnexpectedResponseException HT.Status | + Neo4jNoSuchProperty T.Text | + Neo4jBatchException L.ByteString | + Neo4jParseException String deriving (Show, Typeable, Eq) +instance Exception Neo4jException + +-- | Type for a connection +data Connection = Connection {dbHostname :: Hostname, dbPort :: Port, manager :: HC.Manager} + +type Hostname = S.ByteString +type Port = Int + +-- | Neo4j monadic type to be able to sequence neo4j commands in a connection +newtype Neo4j a = Neo4j { runNeo4j :: Connection -> ResourceT IO a } + +instance Monad Neo4j where + return x = Neo4j (const (return x)) + (Neo4j cmd) >>= f = Neo4j $ \con -> do + a <- cmd con + runNeo4j (f a) con + +instance MonadIO Neo4j where + liftIO f = Neo4j $ const (liftIO f) diff --git a/tests/IntegrationTests.hs b/tests/IntegrationTests.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests.hs @@ -0,0 +1,1177 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} +module Main where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Monoid (Monoid, mappend) +import Data.Int (Int64) +import Data.Maybe (fromJust) + +import qualified Data.ByteString as S +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as HS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Control.Exception (handle) +import Test.Framework.TH (defaultMainGenerator) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit.Base hiding (Test, Node) + +import Database.Neo4j +import qualified Database.Neo4j.Graph as G +import qualified Database.Neo4j.Batch as B + +(<>) :: Monoid a => a -> a -> a +(<>) = mappend + +-- Get the string of a exception raised by an action +getException :: IO a -> IO (Maybe Neo4jException) +getException action = handle (return . Just) $ do + _ <- action + return Nothing + +assertException :: Neo4jException -> IO a -> Assertion +assertException exExc action = do + resExc <- getException action + checkExc resExc + where --checkExc :: (Exception e, Show e) => Maybe e -> Assertion + checkExc Nothing = assertFailure $ "Expected exception " <> show exExc <> " but none raised" + checkExc (Just e) = assertEqual "" exExc e + +-- | handy assertEqual inside a Neo4j monad +neo4jEqual :: (Show a, Eq a) => a -> a -> Neo4j () +neo4jEqual a b = liftIO $ assertEqual "" a b + +-- | handy assertBool inside a Neo4j monad +neo4jBool :: Bool -> Neo4j () +neo4jBool f = liftIO $ assertBool "" f + + +main :: IO () +main = $(defaultMainGenerator) + +-- TODO: Is it possible to avoid so many type declarations for literals when constructing properties?? +-- | Dummy properties +someProperties :: Properties +someProperties = M.fromList ["mytext" |: ("mytext" :: T.Text), + "textarrayprop" |: ["a" :: T.Text, "", "adeu"], + "int" |: (-12 :: Int64), + "intarray" |: [1 :: Int64, 2], + "double" |: (-12.23 :: Double), + "doublearray" |: [0.1, -12.23 :: Double], + "bool" |: False, + "aboolproparray" |: [False, True] + ] + +-- | Default Neo4j port +port :: Port +port = 7474 + +-- | Default Neo4j host +host :: Hostname +host = "localhost" + +-- | Test connecting to a non-existing server +case_NoConnection :: Assertion +case_NoConnection = assertException expException $ withConnection "localhost" 77 $ createNode someProperties + where expException = Neo4jHttpException "FailedConnectionException2 \"localhost\" 77 False connect: does\ + \ not exist (Connection refused)" + +-- | Test get and create a node +case_CreateGetDeleteNode :: Assertion +case_CreateGetDeleteNode = withConnection host port $ do + n <- createNode someProperties + newN <- getNode n + neo4jEqual (Just n) newN + deleteNode n + +-- | Test delete and get a node +case_CreateDeleteGetNode :: Assertion +case_CreateDeleteGetNode = withConnection host port $ do + n <- createNode someProperties + deleteNode n + newN <- getNode n + neo4jEqual Nothing newN + +-- | Test double delete +case_DoubleDeleteNode :: Assertion +case_DoubleDeleteNode = withConnection host port $ do + n <- createNode someProperties + deleteNode n + deleteNode n + +-- | Test get node by id +case_GetNodeById :: Assertion +case_GetNodeById = withConnection host port $ do + n <- createNode someProperties + newN <- getNode (nodeId n) + neo4jEqual (Just n) newN + deleteNode n + +-- | Test get node with unexisting id +case_GetUnexistingNodeById :: Assertion +case_GetUnexistingNodeById = withConnection host port $ do + newN <- getNode ("unexistingnode" :: S.ByteString) + neo4jEqual Nothing newN + +-- | Test delete node by id +case_DeleteNodeById :: Assertion +case_DeleteNodeById = withConnection host port $ do + n <- createNode someProperties + deleteNode (nodeId n) + +-- | Test delete unexisting node by id +case_DeleteUnexistingNodeById :: Assertion +case_DeleteUnexistingNodeById = withConnection host port $ deleteNode ("unexistingnode" :: S.ByteString) + +-- | Refresh node properties from the DB +case_getNodeProperties :: Assertion +case_getNodeProperties = withConnection host port $ do + n <- createNode someProperties + props <- getProperties n + neo4jEqual someProperties props + deleteNode n + +-- | Get node properties from a deleted node +case_getDeletedNodeProperties :: Assertion +case_getDeletedNodeProperties = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + getProperties n + +-- | Get a property from a node +case_getNodeProperty :: Assertion +case_getNodeProperty = withConnection host port $ do + n <- createNode someProperties + prop <- getProperty n "intarray" + neo4jEqual (M.lookup "intarray" someProperties) prop + deleteNode n + +-- | Get an unexisting property from a node +case_getNodeUnexistingProperty :: Assertion +case_getNodeUnexistingProperty = withConnection host port $ do + n <- createNode someProperties + prop <- getProperty n "noproperty" + neo4jEqual Nothing prop + deleteNode n + +-- | Get a property from an unexisting node +case_getUnexistingNodeProperty :: Assertion +case_getUnexistingNodeProperty = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + _ <- getProperty n "noproperty" + return () + +-- | Get change the properties of a node +case_changeNodeProperties :: Assertion +case_changeNodeProperties = withConnection host port $ do + n <- createNode someProperties + newN <- setProperties n otherProperties + neo4jEqual otherProperties (getNodeProperties newN) + renewN <- getNode n + neo4jEqual otherProperties (getNodeProperties $ fromJust renewN) + deleteNode newN + where otherProperties = M.insert "newbool" (newval True) someProperties + +-- | Get change the properties of a node that doesn't exist +case_changeUnexistingNodeProperties :: Assertion +case_changeUnexistingNodeProperties = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + setProperties n someProperties + +-- | Change a property of a node +case_changeNodeProperty :: Assertion +case_changeNodeProperty = withConnection host port $ do + n <- createNode someProperties + newN <- setProperty n otherValName otherVal + neo4jEqual otherProperties (getNodeProperties newN) + renewN <- getNode n + neo4jEqual otherProperties (getNodeProperties $ fromJust renewN) + deleteNode newN + where otherProperties = M.insert otherValName otherVal someProperties + otherValName = "int" + otherVal = newval False + +-- | Change an array property of a node to empty +case_changeNodePropertyToEmpty :: Assertion +case_changeNodePropertyToEmpty = withConnection host port $ do + n <- createNode someProperties + newN <- setProperty n otherValName otherVal + neo4jEqual otherProperties (getNodeProperties newN) + renewN <- getNode n + neo4jEqual otherProperties (getNodeProperties $ fromJust renewN) + deleteNode newN + where otherProperties = M.insert otherValName otherVal someProperties + otherValName = "intarray" + otherVal = newval ([] :: [Int64]) + +-- | Set an unexisting property of a node +case_changeNodeUnexistingProperty :: Assertion +case_changeNodeUnexistingProperty = withConnection host port $ do + n <- createNode someProperties + newN <- setProperty n otherValName otherVal + neo4jEqual otherProperties (getNodeProperties newN) + renewN <- getNode n + neo4jEqual otherProperties (getNodeProperties $ fromJust renewN) + deleteNode newN + where otherProperties = M.insert otherValName otherVal someProperties + otherValName = "mynewbool" + otherVal = newval False + +-- | Set property of an unexisting node +case_changeUnexistingNodeProperty :: Assertion +case_changeUnexistingNodeProperty = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + _ <- setProperty n otherValName otherVal + return () + where otherValName = "mynewbool" + otherVal = newval False + +-- | Delete node properties +case_deleteNodeProperties :: Assertion +case_deleteNodeProperties = withConnection host port $ do + n <- createNode someProperties + newN <- deleteProperties n + neo4jEqual M.empty (getNodeProperties newN) + renewN <- getNode n + neo4jEqual M.empty (getNodeProperties $ fromJust renewN) + deleteNode newN + +-- | Delete unexisting node properties +case_deleteUnexistingNodeProperties :: Assertion +case_deleteUnexistingNodeProperties = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + _ <- deleteProperties n + return () + +-- | Delete a node property +case_deleteNodeProperty :: Assertion +case_deleteNodeProperty = withConnection host port $ do + n <- createNode someProperties + newN <- deleteProperty n valName + neo4jEqual otherProperties (getNodeProperties newN) + renewN <- getNode n + neo4jEqual otherProperties (getNodeProperties $ fromJust renewN) + deleteNode newN + where otherProperties = M.delete valName someProperties + valName = "int" + +-- | Delete an unexisting property from a node +case_deleteNodeUnexistingProperty :: Assertion +case_deleteNodeUnexistingProperty = withConnection host port $ do + n <- createNode someProperties + newN <- deleteProperty n valName + neo4jEqual otherProperties (getNodeProperties newN) + renewN <- getNode n + neo4jEqual otherProperties (getNodeProperties $ fromJust renewN) + deleteNode newN + where otherProperties = M.delete valName someProperties + valName = "noproperty" + +-- | Delete a property from an unexisting node +case_deleteUnexistingNodeProperty :: Assertion +case_deleteUnexistingNodeProperty = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + _ <- deleteProperty n valName + return () + where valName = "noproperty" + +someOtherProperties :: Properties +someOtherProperties = M.fromList ["hola" |: ("adeu" :: T.Text), "proparray" |: ["a" :: T.Text, "", "adeu"]] + +anotherProperties :: Properties +anotherProperties = M.empty + +myRelType :: T.Text +myRelType = "MYREL" + +setupRelTests :: Neo4j (Node, Node, Relationship) +setupRelTests = do + nodeFrom <- createNode anotherProperties + nodeTo <- createNode someOtherProperties + r <- createRelationship myRelType someProperties nodeFrom nodeTo + return (nodeFrom, nodeTo, r) + +teardownRelTests :: Node -> Node -> Relationship -> Neo4j() +teardownRelTests f t r = do + deleteRelationship r + deleteNode f + deleteNode t + +-- | Delete a node with a relationship +case_deleteNodeWithRelationship :: Assertion +case_deleteNodeWithRelationship = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNonOrphanNodeDeletionException $ runNodeIdentifier nodeFrom + assertException expException $ withConnection host port $ deleteNode nodeFrom + withConnection host port $ teardownRelTests nodeFrom nodeTo r + +-- | Test get and create a relationship +case_CreateGetDeleteRelationship :: Assertion +case_CreateGetDeleteRelationship = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- getRelationship r + neo4jEqual (Just r) newN + teardownRelTests nodeFrom nodeTo r + +-- | Test get all relationship properties +case_allRelationshipProperties :: Assertion +case_allRelationshipProperties = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + rs <- allRelationshipTypes + neo4jBool $ myRelType `elem` rs + teardownRelTests nodeFrom nodeTo r + +-- | Test get the start and end of a relationship +case_relationshipFromTo :: Assertion +case_relationshipFromTo = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + nfrom <- getRelationshipFrom r + neo4jEqual nodeFrom nfrom + nto <- getRelationshipTo r + neo4jEqual nodeTo nto + teardownRelTests nodeFrom nodeTo r + +-- | Test get the start of relationship that doesn't exist any more +case_nonExistingRelationshipFrom :: Assertion +case_nonExistingRelationshipFrom = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runNodeIdentifier nodeFrom + assertException expException $ withConnection host port $ do + deleteRelationship r + deleteNode nodeFrom + n <- getRelationshipFrom r + neo4jEqual nodeFrom n -- Doing this to force the evaluation of n (the exception is thrown after parsing) + return () + withConnection host port $ teardownRelTests nodeFrom nodeTo r + +-- | Test get the end of relationship that doesn't exist any more +case_nonExistingRelationshipTo :: Assertion +case_nonExistingRelationshipTo = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runNodeIdentifier nodeTo + assertException expException $ withConnection host port $ do + deleteRelationship r + deleteNode nodeTo + n <- getRelationshipTo r + neo4jEqual nodeTo n -- Doing this to force the evaluation of n (the exception is thrown after parsing) + return () + withConnection host port $ teardownRelTests nodeFrom nodeTo r + +-- | Create relationship with missing node from +case_CreateRelationshipMissingFrom :: Assertion +case_CreateRelationshipMissingFrom = do + (nodeFrom, nodeTo) <- withConnection host port $ do + nodeFrom <- createNode anotherProperties + nodeTo <- createNode someOtherProperties + return (nodeFrom, nodeTo) + let expException = Neo4jNoEntityException $ runNodeIdentifier nodeFrom + assertException expException $ withConnection host port $ do + deleteNode nodeFrom + _ <- createRelationship myRelType someProperties nodeFrom nodeTo + return () + withConnection host port $ deleteNode nodeTo + +-- | Create relationship with missing node to +case_CreateRelationshipMissingTo :: Assertion +case_CreateRelationshipMissingTo = do + (nodeFrom, nodeTo) <- withConnection host port $ do + nodeFrom <- createNode anotherProperties + nodeTo <- createNode someOtherProperties + return (nodeFrom, nodeTo) + let expException = Neo4jNoEntityException $ runNodeIdentifier nodeTo + assertException expException $ withConnection host port $ do + deleteNode nodeTo + _ <- createRelationship myRelType someProperties nodeFrom nodeTo + return () + withConnection host port $ deleteNode nodeFrom + +-- | Test delete and get a relationship +case_CreateDeleteGetRelationship :: Assertion +case_CreateDeleteGetRelationship = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + deleteRelationship r + newN <- getRelationship r + neo4jEqual Nothing newN + teardownRelTests nodeFrom nodeTo r + +-- | Test double delete +case_DoubleDeleteRelationship :: Assertion +case_DoubleDeleteRelationship = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + deleteRelationship r + deleteRelationship r + teardownRelTests nodeFrom nodeTo r + +-- | Test get relationship by id +case_GetRelationshipById :: Assertion +case_GetRelationshipById = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- getRelationship (relId r) + neo4jEqual (Just r) newN + teardownRelTests nodeFrom nodeTo r + +-- | Test get relationship with unexisting id +case_GetUnexistingRelationshipById :: Assertion +case_GetUnexistingRelationshipById = withConnection host port $ do + newN <- getRelationship ("unexistingrelationship" :: S.ByteString) + neo4jEqual Nothing newN + +-- | Test delete relationship by id +case_DeleteRelationshipById :: Assertion +case_DeleteRelationshipById = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + deleteRelationship (relId r) + teardownRelTests nodeFrom nodeTo r + +-- | Test delete unexisting relationship by id +case_DeleteUnexistingRelationshipById :: Assertion +case_DeleteUnexistingRelationshipById = withConnection host port $ + deleteRelationship ("unexistingrelationship" :: S.ByteString) + +-- | Refresh relationship properties from the DB +case_getRelationshipProperties :: Assertion +case_getRelationshipProperties = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + props <- getProperties r + neo4jEqual someProperties props + teardownRelTests nodeFrom nodeTo r + +-- | Get relationship properties from a deleted node +case_getDeletedRelationshipProperties :: Assertion +case_getDeletedRelationshipProperties = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runRelIdentifier r + assertException expException $ withConnection host port $ do + deleteRelationship r + deleteNode nodeFrom + deleteNode nodeTo + getProperties r + +-- | Get a property from a relationship +case_getRelationshipProperty :: Assertion +case_getRelationshipProperty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + prop <- getProperty r "intarray" + neo4jEqual (M.lookup "intarray" someProperties) prop + teardownRelTests nodeFrom nodeTo r + +-- | Get an unexisting property from a relationship +case_getRelationshipUnexistingProperty :: Assertion +case_getRelationshipUnexistingProperty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + prop <- getProperty r "noproperty" + neo4jEqual Nothing prop + teardownRelTests nodeFrom nodeTo r + +-- | Get a property from an unexisting relationship +case_getUnexistingRelationshipProperty :: Assertion +case_getUnexistingRelationshipProperty = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runRelIdentifier r + assertException expException $ withConnection host port $ do + teardownRelTests nodeFrom nodeTo r + _ <- getProperty r "noproperty" + return () + +-- | Get change the properties of a relationship +case_changeRelationshipProperties :: Assertion +case_changeRelationshipProperties = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- setProperties r otherProperties + neo4jEqual otherProperties (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual otherProperties (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + where otherProperties = M.insert "newbool" (newval True) someProperties + +-- | Get change the properties of a relationship that doesn't exist +case_changeUnexistingRelationshipProperties :: Assertion +case_changeUnexistingRelationshipProperties = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runRelIdentifier r + assertException expException $ withConnection host port $ do + deleteRelationship r + deleteNode nodeFrom + deleteNode nodeTo + setProperties r someProperties + +-- | Change a property of a relationship +case_changeRelationshipProperty :: Assertion +case_changeRelationshipProperty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- setProperty r otherValName otherVal + neo4jEqual otherProperties (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual otherProperties (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + where otherProperties = M.insert otherValName otherVal someProperties + otherValName = "int" + otherVal = newval False + +-- | Change an array property of a relationship to empty +case_changeRelationshipPropertyToEmpty :: Assertion +case_changeRelationshipPropertyToEmpty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- setProperty r otherValName otherVal + neo4jEqual otherProperties (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual otherProperties (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + where otherProperties = M.insert otherValName otherVal someProperties + otherValName = "intarray" + otherVal = newval ([] :: [Int64]) + +-- | Set an unexisting property of a relationship +case_changeRelationshipUnexistingProperty :: Assertion +case_changeRelationshipUnexistingProperty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- setProperty r otherValName otherVal + neo4jEqual otherProperties (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual otherProperties (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + where otherProperties = M.insert otherValName otherVal someProperties + otherValName = "mynewbool" + otherVal = newval False + +-- | Set property of an unexisting node +case_changeUnexistingRelationshipProperty :: Assertion +case_changeUnexistingRelationshipProperty = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runRelIdentifier r + assertException expException $ withConnection host port $ do + deleteRelationship r + _ <- setProperty r otherValName otherVal + return () + withConnection host port $ teardownRelTests nodeFrom nodeTo r + where otherValName = "mynewbool" + otherVal = newval False + +-- | Delete relationship properties +case_deleteRelationshipProperties :: Assertion +case_deleteRelationshipProperties = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- deleteProperties r + neo4jEqual M.empty (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual M.empty (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + +-- | Delete unexisting relationship properties +case_deleteUnexistingRelationshipProperties :: Assertion +case_deleteUnexistingRelationshipProperties = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runRelIdentifier r + assertException expException $ withConnection host port $ do + deleteRelationship r + _ <- deleteProperties r + return () + withConnection host port $ teardownRelTests nodeFrom nodeTo r + +-- | Delete a relationship property +case_deleteRelationshipProperty :: Assertion +case_deleteRelationshipProperty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- deleteProperty r valName + neo4jEqual otherProperties (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual otherProperties (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + where otherProperties = M.delete valName someProperties + valName = "int" + +-- | Delete an unexisting property from a relationship +case_deleteRelationshipUnexistingProperty :: Assertion +case_deleteRelationshipUnexistingProperty = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + newN <- deleteProperty r valName + neo4jEqual otherProperties (getRelProperties newN) + renewN <- getRelationship r + neo4jEqual otherProperties (getRelProperties $ fromJust renewN) + teardownRelTests nodeFrom nodeTo newN + where otherProperties = M.delete valName someProperties + valName = "noproperty" + +-- | Delete a property from an unexisting relationship +case_deleteUnexistingRelationshipProperty :: Assertion +case_deleteUnexistingRelationshipProperty = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runRelIdentifier r + assertException expException $ withConnection host port $ do + deleteRelationship r + _ <- deleteProperty r valName + return () + withConnection host port $ teardownRelTests nodeFrom nodeTo r + where valName = "noproperty" + +-- | Get relationships for a node +case_GetNodeRelationships :: Assertion +case_GetNodeRelationships = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + -- test getting relationships for the origin node + rsAny <- getRelationships nodeFrom Any [] + neo4jEqual [r] rsAny + rsOutgoing <- getRelationships nodeFrom Outgoing [] + neo4jEqual [r] rsOutgoing + rsIncoming <- getRelationships nodeFrom Incoming [] + neo4jEqual [] rsIncoming + -- test getting relationships for the destination node + rsAnyTo <- getRelationships nodeTo Any [] + neo4jEqual [r] rsAnyTo + rsOutgoingTo <- getRelationships nodeTo Outgoing [] + neo4jEqual [] rsOutgoingTo + rsIncomingTo <- getRelationships nodeTo Incoming [] + neo4jEqual [r] rsIncomingTo + teardownRelTests nodeFrom nodeTo r + +-- | Get relationships for an unexisting node +case_GetUnexistingNodeRelationships :: Assertion +case_GetUnexistingNodeRelationships = do + (nodeFrom, nodeTo, r) <- withConnection host port setupRelTests + let expException = Neo4jNoEntityException $ runNodeIdentifier nodeFrom + assertException expException $ withConnection host port $ do + teardownRelTests nodeFrom nodeTo r + _ <- getRelationships nodeFrom Any [] + return () + +-- | Get relationships for a node with multiple relationships +case_GetNodeRelationshipsMultiple :: Assertion +case_GetNodeRelationshipsMultiple = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + r2 <- createRelationship myRelType someOtherProperties nodeTo nodeFrom + rsAny <- getRelationships nodeFrom Any [] + neo4jBool (r `elem` rsAny) + neo4jBool (r2 `elem` rsAny) + neo4jEqual 2 (length rsAny) + rsOutgoing <- getRelationships nodeFrom Outgoing [] + neo4jEqual [r] rsOutgoing + rsIncoming <- getRelationships nodeFrom Incoming [] + neo4jEqual [r2] rsIncoming + deleteRelationship r2 + teardownRelTests nodeFrom nodeTo r + +-- | Get relationships for a node with a type filter +case_GetNodeRelationshipsWithType :: Assertion +case_GetNodeRelationshipsWithType = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + rsAny <- getRelationships nodeFrom Any [myRelType] + neo4jEqual [r] rsAny + teardownRelTests nodeFrom nodeTo r + +-- | Get relationships for a node with an unexisting type filter +case_GetNodeRelationshipsWithUnexistingType :: Assertion +case_GetNodeRelationshipsWithUnexistingType = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + rsAny <- getRelationships nodeFrom Any ["notype"] + neo4jEqual [] rsAny + teardownRelTests nodeFrom nodeTo r + +-- | Get relationships for a node with a type filter with multiple elements +case_GetNodeRelationshipsWithTypes :: Assertion +case_GetNodeRelationshipsWithTypes = withConnection host port $ do + (nodeFrom, nodeTo, r) <- setupRelTests + -- Create another relationship with another type + r2 <- createRelationship type2 anotherProperties nodeTo nodeFrom + rsAny <- getRelationships nodeFrom Any [myRelType, type2, "notype"] + neo4jBool (r `elem` rsAny) + neo4jBool (r2 `elem` rsAny) + neo4jEqual 2 (length rsAny) + deleteRelationship r2 + teardownRelTests nodeFrom nodeTo r + where type2 = "reltype2" + +-- | Get all labels in the DB (We don't have control of all the labels the DB has) +case_getLabels :: Assertion +case_getLabels = withConnection host port $ do + n <- createNode someProperties + addLabels [lbl] n + lbls <- allLabels + neo4jBool $ lbl `elem` lbls + deleteNode n + where lbl = "label1" + +-- | Get labels for a node it doesn't have any +case_getNodeLabelsWithNone :: Assertion +case_getNodeLabelsWithNone = withConnection host port $ do + n <- createNode someProperties + lbls <- getLabels n + neo4jEqual [] lbls + deleteNode n + +-- | Get labels for an unexisting node +case_getUnexistingNodeLabels :: Assertion +case_getUnexistingNodeLabels = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + _ <- getLabels n + return () + +-- | Add labels to a node and get them +case_getAddAndGetNodeLabels :: Assertion +case_getAddAndGetNodeLabels = withConnection host port $ do + n <- createNode someProperties + addLabels [lbl1, lbl2] n + addLabels [lbl3] n + lbls <- getLabels n + neo4jEqual 3 (length lbls) + neo4jBool $ all (`elem` lbls) [lbl1, lbl2, lbl3] + deleteNode n + where lbl1 = "mylabel1" + lbl2 = "mylabel2" + lbl3 = "mylabel3" + +-- | Add labels to an unexisting node +case_addUnexistingNodeLabels :: Assertion +case_addUnexistingNodeLabels = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + addLabels ["mylabel"] n + +-- | Change node labels +case_changeNodeLabels :: Assertion +case_changeNodeLabels = withConnection host port $ do + n <- createNode someProperties + addLabels [lbl1, lbl2] n + changeLabels [lbl3] n + lbls <- getLabels n + neo4jEqual [lbl3] lbls + deleteNode n + where lbl1 = "mylabel1" + lbl2 = "mylabel2" + lbl3 = "otherlabel" + +-- | Change node labels to empty +case_changeNodeLabelsToEmpty :: Assertion +case_changeNodeLabelsToEmpty = withConnection host port $ do + n <- createNode someProperties + addLabels [lbl1, lbl2] n + changeLabels [] n + lbls <- getLabels n + neo4jEqual [] lbls + deleteNode n + where lbl1 = "mylabel1" + lbl2 = "mylabel2" + +-- | Change labels for an unexisting node +case_changeUnexistingNodeLabels :: Assertion +case_changeUnexistingNodeLabels = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + changeLabels ["mylabel"] n + +-- | Remove a label from a node +case_removeNodeLabel :: Assertion +case_removeNodeLabel = withConnection host port $ do + n <- createNode someProperties + addLabels [lbl1, lbl2] n + removeLabel lbl1 n + lbls <- getLabels n + neo4jEqual [lbl2] lbls + deleteNode n + where lbl1 = "mylabel1" + lbl2 = "mylabel2" + +-- | Remove an unexisting label from a node (nothing should happen) +case_removeNodeUnexistingLabel :: Assertion +case_removeNodeUnexistingLabel = withConnection host port $ do + n <- createNode someProperties + addLabels [lbl1] n + removeLabel "nolabel" n + lbls <- getLabels n + neo4jEqual [lbl1] lbls + deleteNode n + where lbl1 = "mylabel1" + +-- | Remove label for an unexisting node +case_removeUnexistingNodeLabel :: Assertion +case_removeUnexistingNodeLabel = do + n <- withConnection host port $ createNode someProperties + let expException = Neo4jNoEntityException $ runNodeIdentifier n + assertException expException $ withConnection host port $ do + deleteNode n + removeLabel "mylabel" n + +-- | Get all nodes with a label +case_allNodesWithLabel :: Assertion +case_allNodesWithLabel = withConnection host port $ do + n1 <- createNode someProperties + n2 <- createNode someProperties + n3 <- createNode someProperties + addLabels [lbl1, lbl2] n1 + addLabels [lbl2] n2 + addLabels [lbl1] n3 + ns <- getNodesByLabelAndProperty lbl1 Nothing + neo4jEqual 2 (length ns) + neo4jBool $ all (`elem` ns) [n1, n3] + ns2 <- getNodesByLabelAndProperty "nolbl" Nothing + neo4jEqual [] ns2 + mapM_ deleteNode [n1, n2, n3] + where lbl1 = "lbl1" + lbl2 = "lbl2" + +-- | Get all nodes with a label and a property +case_allNodesWithLabelAndProperty :: Assertion +case_allNodesWithLabelAndProperty = withConnection host port $ do + n1 <- createNode someProperties + n2 <- createNode someProperties + n3 <- createNode anotherProperties + addLabels [lbl1, lbl2] n1 + addLabels [lbl2] n2 + addLabels [lbl1] n3 + ns <- getNodesByLabelAndProperty lbl1 $ Just ("doublearray", newval [0.1, -12.23 :: Double]) + neo4jEqual [n1] ns + ns2 <- getNodesByLabelAndProperty lbl1 $ Just ("doublearray", newval [0.1, -12.22 :: Double]) + neo4jEqual [] ns2 + mapM_ deleteNode [n1, n2, n3] + where lbl1 = "lbl1" + lbl2 = "lbl2" + +-- | Create, get and destroy index +case_createGetDropIndex :: Assertion +case_createGetDropIndex = withConnection host port $ do + dropIndex lbl prop1 + dropIndex lbl prop2 + dropIndex lbl2 prop1 + dropIndex lbl2 prop2 + idx1 <- createIndex lbl prop1 + idx2 <- createIndex lbl prop2 + idx3 <- createIndex lbl2 prop1 + idx4 <- createIndex lbl2 prop2 + idxs <- getIndexes lbl + neo4jBool $ all (`elem` idxs) [idx1, idx2] + neo4jBool $ all (not . (`elem` idxs)) [idx3, idx4] + idxs2 <- getIndexes lbl2 + neo4jBool $ all (not . (`elem` idxs2)) [idx1, idx2] + neo4jBool $ all (`elem` idxs2) [idx3, idx4] + dropIndex lbl prop1 + dropIndex lbl prop2 + dropIndex lbl2 prop1 + dropIndex lbl2 prop2 + idxs3 <- getIndexes lbl + idxs4 <- getIndexes lbl2 + neo4jBool $ all (not . (`elem` idxs3)) [idx1, idx2] + neo4jBool $ all (not . (`elem` idxs4)) [idx3, idx4] + where lbl = "mylabel11" + lbl2 = "mylabel2" + prop1 = "myprop" + prop2 = "myprop2" + +-- | Test batch, create a node and get it again +case_batchCreateGetNode :: Assertion +case_batchCreateGetNode = withConnection host port $ do + g <- B.runBatch $ do + n <- B.createNode someProperties + B.getNode n + neo4jEqual 1 (length $ G.getNodes g) + neo4jBool $ someProperties `elem` map getNodeProperties (G.getNodes g) + deleteNode (head $ G.getNodes g) + +-- | Test batch, create two nodes in a batch +case_batchCreate2Nodes :: Assertion +case_batchCreate2Nodes = withConnection host port $ do + g <- B.runBatch $ do + _ <- B.createNode someProperties + B.createNode anotherProperties + neo4jEqual 2 (length $ G.getNodes g) + neo4jBool $ someProperties `elem` map getNodeProperties (G.getNodes g) + neo4jBool $ anotherProperties `elem` map getNodeProperties (G.getNodes g) + mapM_ deleteNode (G.getNodes g) + +-- | Test batch, create and delete +case_batchCreateDeleteNode :: Assertion +case_batchCreateDeleteNode = withConnection host port $ do + g <- B.runBatch $ do + n <- B.createNode someProperties + B.deleteNode n + neo4jEqual 0 (length $ G.getNodes g) + +-- | Test batch, create two nodes and two relationships between them +case_batchCreateRelationships :: Assertion +case_batchCreateRelationships = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + _ <- B.createRelationship "type1" someOtherProperties n1 n2 + B.createRelationship "type2" someProperties n2 n1 + neo4jEqual 2 (length $ G.getNodes g) + neo4jEqual 2 (length $ G.getRelationships g) + neo4jBool $ someOtherProperties `elem` map getRelProperties (G.getRelationships g) + neo4jBool $ someProperties `elem` map getRelProperties (G.getRelationships g) + neo4jBool $ "type1" `elem` map getRelType (G.getRelationships g) + neo4jBool $ "type2" `elem` map getRelType (G.getRelationships g) + let r1 : r2 : [] = G.getRelationships g + neo4jEqual (G.getRelationshipNodeFrom r1 g) (G.getRelationshipNodeTo r2 g) + neo4jEqual (G.getRelationshipNodeFrom r2 g) (G.getRelationshipNodeTo r1 g) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, create and delete a relationship +case_batchCreateDelRelationships :: Assertion +case_batchCreateDelRelationships = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + r <- B.createRelationship "type1" someOtherProperties n1 n2 + B.deleteRelationship r + neo4jEqual 2 (length $ G.getNodes g) + neo4jEqual 0 (length $ G.getRelationships g) + mapM_ deleteRelationship (G.getRelationships g) + mapM_ deleteNode (G.getNodes g) + +-- | Test batch getRelationshipFrom +case_batchRelationshipNodeFrom :: Assertion +case_batchRelationshipNodeFrom = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + B.createRelationship "type1" someOtherProperties n1 n2 + g2 <- B.runBatch $ B.getRelationshipFrom (head $ G.getRelationships g) + neo4jEqual 1 (length $ G.getNodes g2) + neo4jEqual 0 (length $ G.getRelationships g2) + neo4jBool $ someProperties `elem` map getNodeProperties (G.getNodes g2) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch getRelationshipTo +case_batchRelationshipNodeTo :: Assertion +case_batchRelationshipNodeTo = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + B.createRelationship "type1" someOtherProperties n1 n2 + g2 <- B.runBatch $ B.getRelationshipTo (head $ G.getRelationships g) + neo4jEqual 1 (length $ G.getNodes g2) + neo4jEqual 0 (length $ G.getRelationships g2) + neo4jBool $ anotherProperties `elem` map getNodeProperties (G.getNodes g2) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, get all relationships with filter +case_batchGetRelationships :: Assertion +case_batchGetRelationships = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + _ <- B.createRelationship "type1" someOtherProperties n1 n2 + B.createRelationship "type2" someProperties n2 n1 + g2 <- B.runBatch $ do + let n = head $ G.getNodes g + B.getRelationships n Any ["type1", "type2"] + neo4jEqual 2 (length $ G.getRelationships g2) + neo4jBool $ someOtherProperties `elem` map getRelProperties (G.getRelationships g2) + neo4jBool $ someProperties `elem` map getRelProperties (G.getRelationships g2) + neo4jBool $ "type1" `elem` map getRelType (G.getRelationships g2) + neo4jBool $ "type2" `elem` map getRelType (G.getRelationships g2) + mapM_ deleteRelationship (G.getRelationships g) + mapM_ deleteNode (G.getNodes g) + +-- | Test batch, set properties +case_batchSetProperties :: Assertion +case_batchSetProperties = withConnection host port $ do + let newProperties = M.fromList ["croqueta" |: ("2" :: T.Text)] + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + r <- B.createRelationship "type1" someOtherProperties n1 n2 + _ <- B.setProperties n1 newProperties + B.setProperties r newProperties + neo4jEqual 2 (length $ G.getNodes g) + neo4jEqual 1 (length $ G.getRelationships g) + neo4jBool $ newProperties `elem` map getRelProperties (G.getRelationships g) + neo4jBool $ newProperties `elem` map getNodeProperties (G.getNodes g) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + + +-- | Test batch, set property +case_batchSetProperty :: Assertion +case_batchSetProperty = withConnection host port $ do + let key = "hola" + let val = newval False + let newSomeProperties = M.insert key val someProperties + let newSomeOtherProperties = M.insert key val someOtherProperties + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + r <- B.createRelationship "type1" someOtherProperties n1 n2 + _ <- B.setProperty n1 key val + B.setProperty r key val + neo4jEqual 2 (length $ G.getNodes g) + neo4jEqual 1 (length $ G.getRelationships g) + neo4jBool $ newSomeProperties `elem` map getNodeProperties (G.getNodes g) + neo4jBool $ newSomeOtherProperties `elem` map getRelProperties (G.getRelationships g) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, delete properties +case_batchDeleteProperties :: Assertion +case_batchDeleteProperties = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + r <- B.createRelationship "type1" someOtherProperties n1 n2 + _ <- B.deleteProperties n1 + B.deleteProperties r + neo4jEqual 2 (length $ G.getNodes g) + neo4jEqual 1 (length $ G.getRelationships g) + neo4jBool $ emptyProperties `elem` map getRelProperties (G.getRelationships g) + neo4jBool $ emptyProperties `elem` map getNodeProperties (G.getNodes g) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, delete property +case_batchDeleteProperty :: Assertion +case_batchDeleteProperty= withConnection host port $ do + let key = "mytext" + let newSomeProperties = M.delete key someProperties + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + r <- B.createRelationship "type1" someProperties n1 n2 + _ <- B.deleteProperty n1 key + B.deleteProperty r key + neo4jEqual 2 (length $ G.getNodes g) + neo4jEqual 1 (length $ G.getRelationships g) + neo4jBool $ newSomeProperties `elem` map getNodeProperties (G.getNodes g) + neo4jBool $ newSomeProperties `elem` map getRelProperties (G.getRelationships g) + _ <- B.runBatch $ do + mapM_ B.deleteRelationship (G.getRelationships g) + mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, delete an unknown property, it should raise an exception +case_batchDeleteUnknownProperty :: Assertion +case_batchDeleteUnknownProperty= do + n <- withConnection host port $ createNode someProperties + let excMsg = "Node[" <> TE.decodeUtf8 (nodeId n) <>"] does not have a property \"" <> prop <> "\"" + let expException = Neo4jNoSuchProperty excMsg + assertException expException $ withConnection host port $ do + g <- B.runBatch $ B.deleteProperty n prop + neo4jEqual G.empty g -- Doing this to force evaluation + withConnection host port $ deleteNode n + where prop = "noprop" :: T.Text + +-- | Test batch, set add labels +case_batchAddLabels :: Assertion +case_batchAddLabels = withConnection host port $ do + let label1 = "label1" + let label2 = "label2" + let label3 = "label3" + let labelset = HS.fromList [label1, label2, label3] + g <- B.runBatch $ do + n1 <- B.createNode someProperties + _ <- B.createNode anotherProperties + _ <- B.addLabels [label1, label2] n1 + B.addLabels [label3] n1 + neo4jEqual 2 (length $ G.getNodes g) + neo4jBool $ labelset `elem` map (`G.getNodeLabels` g) (G.getNodes g) + neo4jBool $ HS.empty `elem` map (`G.getNodeLabels` g) (G.getNodes g) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, change labels +case_batchChangeLabels :: Assertion +case_batchChangeLabels = withConnection host port $ do + let label1 = "label1" + let label2 = "label2" + let label3 = "label3" + let labelset = HS.fromList [label2] + g <- B.runBatch $ do + n1 <- B.createNode someProperties + _ <- B.addLabels [label1, label2, label3] n1 + B.changeLabels [label2] n1 + neo4jBool $ labelset `elem` map (`G.getNodeLabels` g) (G.getNodes g) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, remove label +case_batchRemoveLabel :: Assertion +case_batchRemoveLabel = withConnection host port $ do + let label1 = "label1" + let label2 = "label2" + let label3 = "label3" + let labelset = HS.fromList [label2, label3] + g <- B.runBatch $ do + n1 <- B.createNode someProperties + _ <- B.addLabels [label1, label2, label3] n1 + B.removeLabel label1 n1 + neo4jBool $ labelset `elem` map (`G.getNodeLabels` g) (G.getNodes g) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes g) + return () + +-- | Test batch, get all nodes with a label +case_batchAllNodesWithLabel :: Assertion +case_batchAllNodesWithLabel = withConnection host port $ do + gp <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode someProperties + n3 <- B.createNode someProperties + _ <- B.addLabels [lbl1, lbl2] n1 + _ <- B.addLabels [lbl2] n2 + B.addLabels [lbl1] n3 + g <- B.runBatch $ B.getNodesByLabelAndProperty lbl1 Nothing + neo4jEqual 2 (length $ G.getNodes g) + neo4jBool $ all (`elem` G.getNodes gp) (G.getNodes g) + gempty <- B.runBatch $ B.getNodesByLabelAndProperty "nolbl" Nothing + neo4jEqual [] (G.getNodes gempty) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where lbl1 = "la21bl1" + lbl2 = "la21bl2" + +-- | Test batch, get all nodes with a label and a property +case_batchAllNodesWithLabelAndProperty :: Assertion +case_batchAllNodesWithLabelAndProperty = withConnection host port $ do + gp <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode someProperties + n3 <- B.createNode anotherProperties + _ <- B.addLabels [lbl1, lbl2] n1 + _ <- B.addLabels [lbl2] n2 + B.addLabels [lbl1] n3 + g <- B.runBatch $ B.getNodesByLabelAndProperty lbl1 $ Just ("doublearray", newval [0.1, -12.23 :: Double]) + neo4jEqual 1 (length $ G.getNodes g) + neo4jBool $ all (`elem` G.getNodes gp) (G.getNodes g) + g2 <- B.runBatch $ B.getNodesByLabelAndProperty lbl1 $ Just ("doublearray", newval [0.1, -12.22 :: Double]) + neo4jEqual [] (G.getNodes g2) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where lbl1 = "lbl1" + lbl2 = "lbl2"