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/hypher.cabal b/hypher.cabal new file mode 100644 --- /dev/null +++ b/hypher.cabal @@ -0,0 +1,88 @@ +name: hypher +version: 0.1.0 +synopsis: A Haskell neo4j client +description: + Library to interact with Neo4j databases. + . + This library covers: + . + -Cypher transactions + . + -CRUD operations for nodes, relationships, labels and indexes + . + -Batch calls for CRUD operations. + . + . + All code has been tested with Neo4j versions 2.0.3 and 2.1.5 +homepage: https://github.com/zoetic-community/hyper.git +license: MIT +license-file: LICENSE +author: Antoni Silvestre & Jeff Taggart +maintainer: jeff@jetaggart.com +copyright: (c) 2015 Jeff Taggart +category: Database +build-type: Simple +cabal-version: >=1.8 + +source-repository this + type: git + location: https://github.com/zoetic-community/hypher.git + tag: master + +Test-Suite test-hypher + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: src, tests + Main-is: IntegrationTests.hs + Build-Depends: base >=4.6 && <4.8, + 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 && < 1.3, + http-conduit ==2.1.*, + http-types ==0.8.*, + resourcet ==1.1.*, + data-default ==0.5.*, + transformers ==0.4.*, + aeson >= 0.7 && < 0.9, + vector ==0.10.*, + scientific ==0.3.*, + unordered-containers ==0.2.*, + transformers-base ==0.4.*, + HTTP ==4000.2.*, + lifted-base ==0.2.*, + hashable ==1.2.*, + monad-control ==0.3.*, + mtl ==2.2.* + +library + hs-source-dirs: src + exposed-modules: Database.Neo4j, Database.Neo4j.Graph, Database.Neo4j.Batch, Database.Neo4j.Cypher, + Database.Neo4j.Transactional.Cypher + 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, Database.Neo4j.Batch.Types + build-depends: base >=4.6 && <4.8, + containers ==0.5.*, + text >= 1.1 && < 1.3, + http-conduit ==2.1.*, + http-types ==0.8.*, + bytestring ==0.10.*, + resourcet ==1.1.*, + data-default ==0.5.*, + transformers ==0.4.*, + aeson >= 0.7 && < 0.9, + vector ==0.10.*, + scientific ==0.3.*, + unordered-containers ==0.2.*, + HTTP ==4000.2.*, + lifted-base ==0.2.*, + hashable ==1.2.*, + transformers-base ==0.4.*, + monad-control ==0.3.*, + 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,131 @@ +{-# 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, NodeIdentifier(..), + NodePath(..), + -- * Managing relationships + Relationship, Direction(..), RelationshipType, createRelationship, getRelationship, deleteRelationship, + getRelationships, relId, relPath, allRelationshipTypes, getRelProperties, getRelType, runRelIdentifier, + getRelationshipFrom, getRelationshipTo, RelIdentifier(..), RelPath(..), + -- * Managing labels and getting nodes by label + EntityIdentifier(..), 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) +-- +-- About Cypher support for now we allow sending queries with parameters, the result is a collection of column headers +-- and JSON data values, the Graph object has the function addCypher that tries to find +-- nodes and relationships in a cypher query result and insert them in a "Database.Neo4j.Graph" object +-- +-- > import qualified Database.Neo4j.Cypher as C +-- > +-- > withConnection host port $ do +-- > ... +-- > -- Run a cypher query with parameters +-- > res <- C.cypher "CREATE (n:Person { name : {name} }) RETURN n" M.fromList [("name", C.newparam ("Pep" :: T.Text))] +-- > +-- > -- Get all nodes and relationships that this query returned and insert them in a Graph object +-- > let graph = G.addCypher (C.fromSuccess res) G.empty +-- > +-- > -- Get the column headers +-- > let columnHeaders = C.cols $ C.fromSuccess res +-- > +-- > -- Get the rows of JSON values received +-- > let values = C.vals $ C.fromSuccess res 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, BatchFuture(..), NodeBatchIdentifier, RelBatchIdentifier, BatchEntity, + -- * 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 . runNodePath . nodePath + +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 . runRelPath . relPath + +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 (flip G.addRelationship) 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/Batch/Types.hs b/src/Database/Neo4j/Batch/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Batch/Types.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Neo4j.Batch.Types where + +import Control.Exception.Base (throw) +import Data.Aeson ((.=), (.:)) +import Data.Maybe (fromMaybe) +import Control.Monad.State (state, State, runState) + +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Network.HTTP.Types as HT + +import Database.Neo4j.Graph +import Database.Neo4j.Http +import Database.Neo4j.Types + +newtype BatchFuture a = BatchFuture Int + +type CmdParser = J.Value -> Graph -> Graph + +data BatchCmd = BatchCmd {cmdMethod :: HT.Method, cmdPath ::T.Text, cmdBody :: J.Value, + cmdParse :: CmdParser, cmdId :: Int} + +defCmd :: BatchCmd +defCmd = BatchCmd{cmdMethod = HT.methodGet, cmdPath = "", cmdBody = "", cmdParse = \_ g -> g, cmdId = -1} + +data BatchState = BatchState {commands :: [BatchCmd], batchId :: Int} + +type Batch a = State BatchState a + +getCmds :: Batch a -> [BatchCmd] +getCmds s = let (_, BatchState cmds _) = runState s (BatchState [] (-1)) in reverse cmds + +instance J.ToJSON (Batch a) where + toJSON b = J.toJSON $ getCmds b + +instance J.ToJSON BatchCmd where + toJSON (BatchCmd m p b _ cId) = J.object ["method" .= TE.decodeUtf8 m, "to" .= p, "body" .= b, "id" .= cId] + +-- | Helper function to parse a batch element response from a body entry +tryParseBody :: J.FromJSON a => J.Value -> a +tryParseBody (J.Object jb) = let res = flip JT.parseEither jb $ \obj -> (obj .: "body") >>= J.parseJSON + in case res of + Right entity -> entity + Left e -> throw $ Neo4jParseException ("Error parsing entity: " ++ e) +tryParseBody _ = throw $ Neo4jParseException "Error expecting an object" + +-- | Helper function to parse a batch element response from a from entry +tryParseFrom :: J.FromJSON a => J.Value -> a +tryParseFrom (J.Object jb) = let res = flip JT.parseEither jb $ \obj -> (obj .: "from") >>= J.parseJSON + in case res of + Right entity -> entity + Left e -> throw $ Neo4jParseException ("Error parsing entity: " ++ e) +tryParseFrom _ = throw $ Neo4jParseException "Error expecting an object" + +nextState :: BatchCmd -> Batch (BatchFuture a) +nextState cmd = state $ \(BatchState cmds cId) -> + (BatchFuture $ cId + 1, BatchState (cmd{cmdId = cId + 1} : cmds) (cId + 1)) + +parseBatchResponse :: J.Array -> Batch a -> Graph +parseBatchResponse jarr b = foldl (flip ($)) empty appliedParsers + where cmds = getCmds b + parsers = foldr (\cmd ps -> cmdParse cmd : ps) [] cmds + appliedParsers = zipWith ($) parsers (V.toList jarr) + +-- | Get teh exception type for a given batch exception message, if nothing is found a default exception is given +exceptionByName :: Neo4jException -> T.Text -> T.Text -> Neo4jException +exceptionByName _ "NoSuchPropertyException" msg = Neo4jNoSuchProperty msg +exceptionByName def _ _ = def + +-- | Parse batch exceptions +parseException :: L.ByteString -> Neo4jException +parseException b = fromMaybe defaultException $ do + parsedobj <- J.decode b + msg <- flip JT.parseMaybe parsedobj $ \obj -> (obj .: "message") >>= J.parseJSON + parsedmsg <- J.decode (L.fromStrict $ TE.encodeUtf8 msg) + (errName, expl) <- flip JT.parseMaybe parsedmsg $ \obj -> do + expl <- obj .: "message" + errName <- obj .: "exception" + return (errName, expl) + return $ exceptionByName defaultException errName expl + where defaultException = Neo4jBatchException b + +runBatch :: Batch a -> Neo4j Graph +runBatch b = Neo4j $ \conn -> do + res <- httpCreate500Explained conn "/db/data/batch" $ J.encode b + let arr = case res of + Left bodyErr -> throw $ parseException bodyErr + Right bodySuc -> bodySuc + return $ parseBatchResponse arr b diff --git a/src/Database/Neo4j/Cypher.hs b/src/Database/Neo4j/Cypher.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Cypher.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | IMPORTANT! MODULE DEPRECATED, better use the code in this same library that uses the Neo4j transactional endpoint +-- in "Database.Neo4j.Transactional.Cypher" +-- Module to provide Cypher support. +-- Currently we allow sending queries with parameters, the result is a collection of column headers +-- and JSON data values, the Graph object has the function addCypher that tries to find +-- nodes and relationships in a cypher query result and insert them in a "Database.Neo4j.Graph" object +-- +-- > import qualified Database.Neo4j.Cypher as C +-- > +-- > withConnection host port $ do +-- > ... +-- > -- Run a cypher query with parameters +-- > res <- C.cypher "CREATE (n:Person { name : {name} }) RETURN n" M.fromList [("name", C.newparam ("Pep" :: T.Text))] +-- > +-- > -- Get all nodes and relationships that this query returned and insert them in a Graph object +-- > let graph = G.addCypher (C.fromSuccess res) G.empty +-- > +-- > -- Get the column headers +-- > let columnHeaders = C.cols $ C.fromSuccess res +-- > +-- > -- Get the rows of JSON values received +-- > let values = C.vals $ C.fromSuccess res +module Database.Neo4j.Cypher ( + -- * Types + Response(..), ParamValue(..), Params, newparam, + -- * Sending queries + cypher, fromResult, fromSuccess, isSuccess + ) where + +import Data.Aeson ((.=), (.:)) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero) + +import qualified Data.Aeson as J +import qualified Data.ByteString as S +import qualified Data.HashMap.Lazy as M +import qualified Data.Text as T + +import Database.Neo4j.Types +import Database.Neo4j.Http + +-- | Type for a Cypher response with tuples containing column name and their values +data Response = Response {cols :: [T.Text], vals :: [[J.Value]]} deriving (Show, Eq) + +-- | How to create a response object from a cypher JSON response +instance J.FromJSON Response where + parseJSON (J.Object o) = Response <$> (o .: "columns" >>= J.parseJSON) <*> (o .: "data" >>= J.parseJSON) + parseJSON _ = mzero + +cypherAPI :: S.ByteString +cypherAPI = "/db/data/cypher" + +-- | Value for a cypher parmeter value, might be a literal, a property map or a list of property maps +data ParamValue = ParamLiteral PropertyValue | ParamProperties Properties | ParamPropertiesArray [Properties] + deriving (Show, Eq) + +newparam :: PropertyValueConstructor a => a -> ParamValue +newparam = ParamLiteral . newval + +-- | Instance toJSON for param values so we can serialize them in queries +instance J.ToJSON ParamValue where + toJSON (ParamLiteral l) = J.toJSON l + toJSON (ParamProperties p) = J.toJSON p + toJSON (ParamPropertiesArray ps) = J.toJSON ps + +-- | We use hashmaps to represent Cypher parameters +type Params = M.HashMap T.Text ParamValue + +-- | Run a cypher query +cypher :: T.Text -> Params -> Neo4j (Either T.Text Response) +cypher cmd params = Neo4j $ \conn -> httpCreate4XXExplained conn cypherAPI body + where body = J.encode $ J.object ["query" .= cmd, "params" .= J.toJSON params] + +-- | Get the result of the response or a default value +fromResult :: Response -> Either T.Text Response -> Response +fromResult def (Left _) = def +fromResult _ (Right resp) = resp + +-- | Get the result of the response or a default value +fromSuccess :: Either T.Text Response -> Response +fromSuccess (Left _) = error "Cypher.fromSuccess but is Error" +fromSuccess (Right resp) = resp + +-- | True if the operation succeeded +isSuccess :: Either T.Text Response -> Bool +isSuccess (Left _) = False +isSuccess (Right _) = True + +{-# DEPRECATED cypher, fromResult, fromSuccess, isSuccess "Use Database.Neo4j.Transactional.Cypher instead" #-} 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,272 @@ +{-# 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. +-- 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, getNode, getNodeFrom, getNodeTo, + -- * Handling properties in the graph object + getRelationships, hasRelationship, addRelationship, deleteRelationship, getRelationshipNodeFrom, + getRelationshipNodeTo, getRelationship, + -- ** Handling orphaned relationships #orphan# + getOrphansFrom, getOrphansTo, cleanOrphanRelationships, + -- * Handling properties + setProperties, setProperty, deleteProperties, deleteProperty, + -- * Handling labels + setNodeLabels, addNodeLabel, getNodeLabels, deleteNodeLabel, + -- * Handling Cypher results + addCypher, + -- * Graph filtering functions + nodeFilter, relationshipFilter, + -- * Graph operations + union, difference, intersection + )where + +import Data.Maybe (fromMaybe) + +import Control.Applicative ((<$>)) +import Control.Monad (join) +import qualified Data.Aeson as J +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as HS +import qualified Data.List as L +import qualified Data.Text as T + +import Database.Neo4j.Types +import qualified Database.Neo4j.Cypher as C + +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 +type RelSet = HS.HashSet RelPath +type NodeRelIndex = M.HashMap NodePath RelSet + +data Graph = Graph {nodes :: NodeIndex, labels :: LabelNodeIndex, rels :: RelIndex, + nodeLabels :: NodeLabelIndex, nodeFromRels :: NodeRelIndex, nodeToRels :: NodeRelIndex + } deriving (Eq, Show) + +-- | Create an empty graph +empty :: Graph +empty = Graph {nodes = M.empty, labels = M.empty, rels = M.empty, nodeLabels = M.empty, nodeFromRels = M.empty, + nodeToRels = 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 $ (addEntity . newEntity) <$> entity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> entityObj <$> M.lookup p (nodes g) + (EntityRelPath p) -> entityObj <$> M.lookup p (rels g) + 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 $ (addEntity . newEntity) <$> entity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> entityObj <$> M.lookup p (nodes g) + (EntityRelPath p) -> entityObj <$> M.lookup p (rels g) + 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 $ (addEntity . newEntity) <$> entity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> entityObj <$> M.lookup p (nodes g) + (EntityRelPath p) -> entityObj <$> M.lookup p (rels g) + 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 $ (addEntity . newEntity) <$> entity + where path = getEntityPath ei + entity = case path of + (EntityNodePath p) -> entityObj <$> M.lookup p (nodes g) + (EntityRelPath p) -> entityObj <$> M.lookup p (rels g) + 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 node in the graph +getNode :: NodeIdentifier a => a -> Graph -> Maybe Node +getNode n g = getNodePath n `M.lookup` nodes g + +-- | Get outgoing relationships from a node +getNodeFrom :: NodeIdentifier a => a -> Graph -> Maybe [Relationship] +getNodeFrom n g = join $ sequence <$> filter (/=Nothing) <$> map getRel <$> fromrels + where getRel = flip getRelationship g + fromrels = HS.toList <$> getNodePath n `M.lookup` nodeFromRels g + +-- | Get incoming relationships from a node +getNodeTo :: NodeIdentifier a => a -> Graph -> Maybe [Relationship] +getNodeTo n g = join $ sequence <$> filter (/=Nothing) <$> map getRel <$> torels + where getRel = flip getRelationship g + torels = HS.toList <$> getNodePath n `M.lookup` nodeToRels g + +-- | Get a list with all the nodes in the graph +getNodes :: Graph -> [Node] +getNodes g = M.elems $ nodes g + +-- | Whether a relationship 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), + nodeFromRels = M.insertWith HS.union (pathFrom r) (HS.singleton relpath) (nodeFromRels g), + nodeToRels = M.insertWith HS.union (pathTo r) (HS.singleton relpath) (nodeToRels g)} + where pathFrom = getNodePath . relFrom + pathTo = getNodePath . relTo + relpath = getRelPath r + +-- | Get a list with all the relationships in the graph +getRelationships :: Graph -> [Relationship] +getRelationships g = M.elems $ rels g + +-- | Get a relationship in the graph +getRelationship :: RelIdentifier a => a -> Graph -> Maybe Relationship +getRelationship r g = getRelPath r `M.lookup` 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), + nodeFromRels = removeNodeRef (nodeFromRels g) pathFrom, + nodeToRels = removeNodeRef (nodeToRels g) pathTo} + where updNodeRel = const $ HS.delete (getRelPath r) + rel = M.lookup (getRelPath r) (rels g) + pathFrom = (getNodePath . relFrom) <$> rel + pathTo = (getNodePath . relTo) <$> rel + removeNodeRef nodeRel (Just nodepath) = M.insertWith updNodeRel nodepath HS.empty nodeRel + removeNodeRef nodeRel Nothing = nodeRel + + +-- | 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 gacc else deleteNode n 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 gacc else deleteRelationship r 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 = addLabels (addRels (addNodes ga gb) gb) gb + where addRels g1 g2 = foldl (\gacc r -> addRelationship r gacc) g1 (getRelationships g2) + addNodes g1 g2 = foldl (flip addNode) g1 (getNodes g2) + addLabels g1 g2 = foldl (\gacc n -> setNodeLabels n (HS.toList $ getNodeLabels n g2) gacc) g1 (getNodes 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 + +-- | Feed a cypher result (from the old API) into a graph (looks for nodes and relationships and inserts them) +addCypher :: C.Response -> Graph -> Graph +addCypher (C.Response _ vals) ginit = foldl tryAdd ginit (concat vals) + where tryAdd :: Graph -> J.Value -> Graph + -- Try first to parse it as a relationship and then as a node, otherwise leave the graph as it is + tryAdd g v = fromMaybe g $ L.find parseSuccess (map ($ v) [relParser g, nodeParser g]) >>= fromResult + relParser g v = flip addRelationship g <$> J.fromJSON v + nodeParser g v = flip addNode g <$> J.fromJSON v + parseSuccess (J.Success _) = True + parseSuccess (J.Error _) = False + fromResult (J.Error _) = Nothing + fromResult (J.Success g) = Just g 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,192 @@ +{-# 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) +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 -> IO Connection +newConnection hostname port = do + mgr <- 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 $ HC.withManager $ + \mgr -> liftIO $ runNeo4j cmds $ Connection hostname port mgr + +-- | General function for HTTP requests +httpReq :: Connection -> HT.Method -> S.ByteString -> L.ByteString -> (HT.Status -> Bool) -> + 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 200 is not received +httpCreate :: J.FromJSON a => Connection -> S.ByteString -> L.ByteString -> 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 and get some headers +httpCreateWithHeaders :: J.FromJSON a => Connection -> S.ByteString -> L.ByteString -> IO (a, HT.ResponseHeaders) +httpCreateWithHeaders conn path body = do + res <- httpReq conn HT.methodPost path body (`elem` [HT.status200, HT.status201]) + let resBody = J.eitherDecode $ HC.responseBody res + let result = case resBody of + Right entity -> entity + Left e -> throw $ Neo4jParseException ("Error parsing created entity: " ++ e) + let headers = HC.responseHeaders res + return (result, headers) + +-- | 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 -> + 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 -> IO (Either T.Text a) +httpCreate4XXExplained conn path body = do + res <- httpReq conn HT.methodPost path body (\s -> s `elem` validcodes ++ errcodes) + let status = HC.responseStatus res + return $ if status `elem` validcodes 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) + validcodes = [HT.status200, HT.status201] + errcodes = [HT.status404, HT.status400] + +-- | 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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" .= runNodePath (nodePath 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/Transactional/Cypher.hs b/src/Database/Neo4j/Transactional/Cypher.hs new file mode 100644 --- /dev/null +++ b/src/Database/Neo4j/Transactional/Cypher.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Module to provide Cypher support using the transactional endpoint. +-- +-- Example: +-- +-- > import qualified Database.Neo4j.Transactional.Cypher as T +-- > +-- > withConnection host port $ do +-- > ... +-- > res <- TC.runTransaction $ do +-- > -- Queries return a result with columns, rows, a list of graphs and stats +-- > result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ +-- > \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ +-- > M.fromList [("age", TC.newparam (78 :: Int64)), +-- > ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] +-- > -- if any of the commands returns an error the transaction is rollbacked and leaves +-- > result 2 <- T.cypher "not a command" M.empty +-- > void $ TC.cypher "CREATE (pep: PERSON {age: 55})" M.empty +-- > -- Transactions are implicitly commited/rollbacked (in case of exception) +-- > -- but can be explicitly committed and rollbacked +-- > return (result, result2) +module Database.Neo4j.Transactional.Cypher ( + -- * Types + Result(..), Stats(..), ParamValue(..), Params, newparam, emptyStats, TransError, Transaction, + -- * Sending queries + loneQuery, runTransaction, cypher, rollback, commit, keepalive, commitWith, rollbackAndLeave, + -- * Aux functions + isSuccess, fromResult, fromSuccess + ) where + +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Except + +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson ((.=), (.:)) +import Data.List (find) +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) + +import qualified Control.Exception as Exc +import qualified Control.Monad.Trans.Resource as R +import qualified Data.Aeson as J +import qualified Data.Acquire as A +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Network.HTTP.Types as HT + +import Database.Neo4j.Types +import Database.Neo4j.Http +import Database.Neo4j.Cypher (ParamValue(..), Params, newparam) +import qualified Database.Neo4j.Graph as G + + +-- | Holds the connection stats +data Stats = Stats {containsUpdates :: Bool, + nodesCreated :: Integer, + nodesDeleted :: Integer, + propsSet :: Integer, + relsCreated :: Integer, + relsDeleted :: Integer, + lblsAdded :: Integer, + lblsRemoved :: Integer, + idxAdded :: Integer, + idxRemoved :: Integer, + constAdded :: Integer, + constRemoved :: Integer} deriving (Eq, Show) + +-- | Type for a Cypher response with tuples containing column name and their values +data Result = Result {cols :: [T.Text], vals :: [[J.Value]], graph :: [G.Graph], stats :: Stats} deriving (Show, Eq) + +-- | Default stats +emptyStats :: Stats +emptyStats = Stats False 0 0 0 0 0 0 0 0 0 0 0 + +-- | An empty response +emptyResponse :: Result +emptyResponse = Result [] [] [] emptyStats + +newtype CypherNode = CypherNode {runCypherNode :: (Node, [Label])} deriving (Eq, Show) +newtype CypherRel = CypherRel {runCypherRel :: Relationship} deriving (Eq, Show) + +readDefault :: Read a => a -> String -> a +readDefault d = fromMaybe d . readMaybe + +readIntDefault :: Integer -> String -> Integer +readIntDefault = readDefault + + +-- | Instance to parse stats from a JSON +instance J.FromJSON Stats where + parseJSON (J.Object o) = Stats <$> o .: "contains_updates" <*> + o .: "nodes_created" <*> + o .: "nodes_deleted" <*> + o .: "properties_set" <*> + o .: "relationships_created" <*> + o .: "relationship_deleted" <*> + o .: "labels_added" <*> + o .: "labels_removed" <*> + o .: "indexes_added" <*> + o .: "indexes_removed" <*> + o .: "constraints_added" <*> + o .: "constraints_removed" + parseJSON _ = mzero + +-- | Instance for the node type in cypher responses +instance J.FromJSON CypherNode where + parseJSON (J.Object o) = CypherNode <$> ((,) <$> parseNode <*> (o .: "labels" >>= J.parseJSON)) + where parseNode = do + idStr <- o .: "id" + props <- o .: "properties" >>= J.parseJSON + return $ Node (getNodePath $ readIntDefault 0 idStr) props + parseJSON _ = mzero + +-- | Instance for the rel type in cypher responses +instance J.FromJSON CypherRel where + parseJSON (J.Object o) = CypherRel <$> (Relationship <$> (relId <$> o .: "id") <*> o .: "type" <*> + (o .: "properties" >>= J.parseJSON) <*> (nodeId <$> o .: "startNode") <*> (nodeId <$> o .: "endNode") ) + where relId = getRelPath . readIntDefault 0 + nodeId = getNodePath . readIntDefault 0 + parseJSON _ = mzero + +-- | Build a graph from a cypher response +buildGraph :: [CypherNode] -> [CypherRel] -> G.Graph +buildGraph ns = foldl addRel (foldl addNode G.empty ns) + where addNode g cn = let (n, lbls) = runCypherNode cn in G.setNodeLabels n lbls (n `G.addNode` g) + addRel g cr = let r = runCypherRel cr in r `G.addRelationship` g + +newtype DataElem = DataElem {runDataElem :: ([J.Value], G.Graph)} deriving (Eq, Show) + +instance J.FromJSON DataElem where + parseJSON (J.Object o) = DataElem <$> ((,) <$> (o .: "row" >>= J.parseJSON) <*> (o .: "graph" >>= parseGraph)) + where parseGraph (J.Object g) = buildGraph <$> (g .: "nodes" >>= J.parseJSON) <*> + (g .: "relationships" >>= J.parseJSON) + parseGraph _ = mzero + parseJSON _ = mzero + +-- | How to create a response object from a cypher JSON response +instance J.FromJSON Result where + parseJSON (J.Object o) = Result <$> (o .: "columns" >>= J.parseJSON) <*> (fst <$> pData) <*> (snd <$> pData) + <*> (o .: "stats" >>= J.parseJSON) + where parseData v = parseDataElem <$> J.parseJSON v + parseDataElem ds = unzip $ map runDataElem ds + pData = o .: "data" >>= parseData + parseJSON _ = mzero + +transAPI :: S.ByteString +transAPI = "/db/data/transaction" + +-- | Error code and message for a transaction error +type TransError = (T.Text, T.Text) + +type TransactionId = S.ByteString + +-- | Different transaction states +data TransState = TransInit | TransStarted R.ReleaseKey TransactionId | TransDone + +type Transaction a = ExceptT TransError (ReaderT Connection (StateT TransState (R.ResourceT IO))) a + +newtype Response = Response {runResponse :: Either TransError Result} deriving (Show, Eq) + +instance J.FromJSON Response where + parseJSON (J.Object o) = do + errs <- o .: "errors" >>= parseErrs + case errs of + Just err -> return $ Response (Left err) + Nothing -> Response . Right <$> (o .: "results" >>= parseResult) + where parseErrs (J.Array es) = if V.null es then return Nothing else Just <$> parseErr (V.head es) + parseErrs _ = mzero + parseErr (J.Object e) = (,) <$> e .: "code" <*> e .: "message" + parseErr _ = mzero + parseResult (J.Array rs) = if V.null rs then return emptyResponse else J.parseJSON $ V.head rs + parseResult _ = mzero + parseJSON _ = mzero + +-- Transaction in one request +loneQuery :: T.Text -> Params -> Neo4j (Either TransError Result) +loneQuery = transactionReq (transAPI <> "/commit") + +-- Generate the body for a query +queryBody :: T.Text -> Params -> L.ByteString +queryBody cmd params = J.encode $ J.object ["statements" .= [ + J.object ["statement" .= cmd, resultSpec, includeStats, + "parameters" .= J.toJSON params]]] + where resultSpec = "resultDataContents" .= ["row", "graph" :: T.Text] + includeStats = "includeStats" .= True + +-- | General function to launch queries inside a transaction +transactionReq :: S.ByteString -> T.Text -> Params -> Neo4j (Either TransError Result) +transactionReq path cmd params = Neo4j $ \conn -> runResponse <$> httpCreate conn path (queryBody cmd params) + +-- | Run a transaction and get its final result, has an implicit commit request (or rollback if an exception occurred). +-- This implicit commit/rollback will only be executed if it hasn't before because of an explicit one +runTransaction :: Transaction a -> Neo4j (Either TransError a) +runTransaction t = Neo4j $ \conn -> + R.runResourceT (fst <$> runStateT (runReaderT (runExceptT $ catchErrors t) conn) TransInit) + +-- | If a query returns an error we have to stop processing the transaction and make sure it's rolled back +catchErrors :: Transaction a -> Transaction a +catchErrors t = catchE t handle + where handle err@("Rollback", _) = ExceptT $ return (Left err) + handle err = do + st <- lift get + -- We can get here from commitWith, which runs and commits, in that case rollback is useless + unless (isDone st) rollback + ExceptT $ return (Left err) + isDone TransDone = True + isDone _ = False + +-- | Run a cypher query in a transaction, if an error occurs the transaction will stop and rollback +cypher :: T.Text -> Params -> Transaction Result +cypher cmd params = do + conn <- ask + st <- lift get + res <- case st of + -- if this is the first query and the transaction hasn't been created yet, create it + TransInit -> do + (key, (resp, headers)) <- lift $ lift $ lift $ reqNewTrans conn + lift $ put (TransStarted key $ transIdFromHeaders headers) + return resp + -- the transaction is already created + TransStarted _ transId -> liftIO $ reqTransCreated conn transId + -- if the transaction has already ended raise an exception + TransDone -> liftIO $ Exc.throw TransactionEndedExc + ExceptT $ return $ runResponse res + where reqNewTrans conn = acquireTrans conn $ httpCreateWithHeaders conn transAPI (queryBody cmd params) + reqTransCreated conn path = httpCreate conn path (queryBody cmd params) + +-- | Rollback a transaction. +-- After this, executing rollback, commit, keepalive, cypher in the transaction will result in an exception +rollback :: Transaction () +rollback = do + conn <- ask + st <- lift get + case st of + TransInit -> return () + TransStarted key transId -> do + liftIO $ rollbackReq conn transId + void $ R.unprotect key + lift $ put TransDone + TransDone -> liftIO $ Exc.throw TransactionEndedExc + +-- | Rollback a transaction and stop processing it, set the message that runTransaction will return as error +rollbackAndLeave :: T.Text -> Transaction () +rollbackAndLeave msg = do + conn <- ask + st <- lift get + case st of + TransInit -> throwE ("Rollback", msg) + TransStarted key transId -> do + liftIO $ rollbackReq conn transId + void $ R.unprotect key + lift $ put TransDone + throwE ("Rollback", msg) + TransDone -> liftIO $ Exc.throw TransactionEndedExc + +-- | Commit a transaction. +-- After this, executing rollback, commit, keepalive, cypher in the transaction will result in an exception +commit :: Transaction () +commit = do + conn <- ask + st <- lift get + case st of + TransInit -> return () + TransStarted key transId -> do + liftIO $ commitReq conn transId + void $ R.unprotect key + lift $ put TransDone + TransDone -> liftIO $ Exc.throw TransactionEndedExc + +-- | Send a cypher query and commit at the same time, if an error occurs the transaction will be rolled back. +-- After this, executing rollback, commit, keepalive, cypher in the transaction will result in an exception +commitWith :: T.Text -> Params -> Transaction Result +commitWith cmd params = do + conn <- ask + st <- lift get + res <- case st of + -- if this is the first query and the transaction hasn't been created yet, create it + TransInit -> liftIO $ req conn (transAPI <> "/commit") + -- the transaction is already created + TransStarted key transId -> do + void $ R.unprotect key + liftIO $ req conn (transId <> "/commit") + -- if the transaction has already ended raise an exception + TransDone -> liftIO $ Exc.throw TransactionEndedExc + lift $ put TransDone + ExceptT $ return $ runResponse res + where req conn path = httpCreate conn path (queryBody cmd params) + +-- | Send a keep alive message to an open transaction +keepalive :: Transaction () +keepalive = do + conn <- ask + st <- lift get + case st of + TransInit -> return () + TransStarted _ transId -> liftIO $ keepaliveReq conn transId + TransDone -> liftIO $ Exc.throw TransactionEndedExc + +-- | Get the transaction ID from the location header +transIdFromHeaders :: HT.ResponseHeaders -> TransactionId +transIdFromHeaders headers = commitId $ fromMaybe (transAPI <> "-1") (snd <$> find ((==HT.hLocation) . fst) headers) + where commitId loc = snd $ S.breakSubstring transAPI loc + +-- | Start a transaction and register the transaction to be committed/rollbacked +acquireTrans :: Connection -> IO (a, HT.ResponseHeaders) -> R.ResourceT IO (R.ReleaseKey, (a, HT.ResponseHeaders)) +acquireTrans conn req = A.allocateAcquire (A.mkAcquireType req freeRes) + where freeRes (_, headers) A.ReleaseNormal = let transId = transIdFromHeaders headers in commitReq conn transId + freeRes (_, headers) _ = let transId = transIdFromHeaders headers in rollbackReq conn transId + +commitReq :: Connection -> TransactionId -> IO () +commitReq conn trId = void $ httpReq conn HT.methodPost (trId <> "/commit") "" (const True) + +rollbackReq :: Connection -> TransactionId -> IO () +rollbackReq conn trId = void $ httpReq conn HT.methodDelete trId "" (const True) + +keepaliveReq :: Connection -> TransactionId -> IO () +keepaliveReq conn trId = void $ httpReq conn HT.methodPost trId keepaliveBody (const True) + where keepaliveBody = J.encode $ J.object ["statements" .= ([] :: [Integer])] + +-- | Get the result of the response or a default value +fromResult :: Result -> Either TransError Result -> Result +fromResult def (Left _) = def +fromResult _ (Right resp) = resp + +-- | Get the result of the response or a default value +fromSuccess :: Either TransError Result -> Result +fromSuccess (Left _) = error "Cypher.fromSuccess but is Error" +fromSuccess (Right resp) = resp + +-- | True if the operation succeeded +isSuccess :: Either TransError Result -> Bool +isSuccess (Left _) = False +isSuccess (Right _) = True 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,357 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Neo4j.Types where + +import Data.Hashable (Hashable) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid, mappend) +import Data.String (fromString) +import Data.Typeable (Typeable) +import Control.Exception (throw) +import Control.Exception.Base (Exception) +import Control.Applicative +import Control.Monad (mzero, ap, liftM) +import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.IO.Class (MonadIO, liftIO) +--import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM, StM) +import Control.Monad.Trans.Resource (MonadThrow, throwM) +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.dropWhile (/='/') <$> T.stripPrefix "http://" url + +-- | 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 + +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 {nodePath :: NodePath, 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 <$> (getNodePath . 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" + +nodeAPITxt :: T.Text +nodeAPITxt = "/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 Integer where + getNodePath n = NodePath $ nodeAPITxt <> "/" <> (fromString . show) n + +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 + +-- | 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 {relPath :: RelPath, + relType :: RelationshipType, + relProperties :: Properties, + relFrom :: NodePath, + relTo :: NodePath} 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 <$> (getRelPath . RelUrl <$> v .: "self") <*> v .: "type" <*> + (v .: "data" >>= J.parseJSON) <*> (getNodePath . NodeUrl <$> v .: "start") <*> + (getNodePath . 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" + +relationshipAPITxt :: T.Text +relationshipAPITxt = "/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 + +instance RelIdentifier Integer where + getRelPath n = RelPath $ relationshipAPITxt <> "/" <> (fromString . show) n + +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 | + TransactionEndedExc 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 -> 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 Functor Neo4j where + fmap = liftM + +instance Applicative Neo4j where + pure = return + (<*>) = ap + +instance MonadIO Neo4j where + liftIO f = Neo4j $ const (liftIO f) + +instance MonadThrow Neo4j where + throwM e = Neo4j $ const (throw e) + +instance MonadBase (Neo4j) (Neo4j) where + liftBase = id + +--instance MonadTransControl Neo4j where +-- newtype StT Neo4j a = StReader {unStReader :: a} +-- liftWith f = ResourceT $ \r -> f $ \(ResourceT t) -> liftM StReader $ t r +-- restoreT = ResourceT . const . liftM unStReader + +--instance MonadBaseControl b IO => MonadBaseControl b (Neo4j) where +-- newtype StM Neo4j a = StNeo4j a +-- liftBaseWith f = Neo4j $ \conn -> +-- liftBaseWith $ \runInBase -> +-- f $ liftM StNeo4j . runInBase . (\(Neo4j r) -> r conn) +-- restoreM (StNeo4j x) = Neo4j $ const $ restoreM x diff --git a/tests/IntegrationTests.hs b/tests/IntegrationTests.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests.hs @@ -0,0 +1,1591 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} +module Main where + +import Control.Monad (void, join) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Monoid (Monoid, mappend) +import Data.Int (Int64) +import Data.Maybe (fromJust) + +import qualified Data.Aeson as J +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 qualified Data.Vector as V + +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.Batch as B +import qualified Database.Neo4j.Cypher as C +import qualified Database.Neo4j.Graph as G +import qualified Database.Neo4j.Transactional.Cypher as TC + +(<>) :: 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" + +someOtherProperties :: Properties +someOtherProperties = M.fromList ["hola" |: ("adeu" :: T.Text), "proparray" |: ["a" :: T.Text, "", "adeu"]] + +anotherProperties :: Properties +anotherProperties = M.empty + +myRelType :: T.Text +myRelType = "MYREL" + + +-- | 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" + +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" + +-- | Test cypher basic test +case_cypherBasic :: Assertion +case_cypherBasic = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ do + n1 <- B.createNode $ M.fromList ["name" |: ("I" :: T.Text)] + n2 <- B.createNode $ M.fromList ["name" |: ("you" :: T.Text)] + B.createRelationship "know" M.empty n1 n2 + -- actual test + res <- C.cypher query params + neo4jBool $ C.isSuccess res + neo4jEqual ["TYPE(r)"] (C.cols $ C.fromSuccess res) + neo4jBool $ ["know"] `elem` (C.vals $ C.fromSuccess res) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (x {name: {startName}})-[r]-(friend) WHERE friend.name = {name} RETURN TYPE(r)" + params = M.fromList [("startName", C.newparam ("I" :: T.Text)), ("name", C.newparam ("you" :: T.Text))] + + +-- | Test cypher create a node +case_cypherCreateNode :: Assertion +case_cypherCreateNode = withConnection host port $ do + res <- C.cypher query params + neo4jBool $ C.isSuccess res + let gp = G.addCypher (C.fromSuccess res) G.empty + let props = M.fromList ["name" |: ("Andres" :: T.Text)] + neo4jEqual 1 (length $ G.getNodes gp) + neo4jBool $ props `elem` map getNodeProperties (G.getNodes gp) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "CREATE (n:Person { name : {name} }) RETURN n" + params = M.fromList [("name", C.newparam ("Andres" :: T.Text))] + +-- | Test cypher create a node with multiple properties +case_cypherCreateNodeMultipleProperties :: Assertion +case_cypherCreateNodeMultipleProperties = withConnection host port $ do + res <- C.cypher query params + neo4jBool $ C.isSuccess res + let gp = G.addCypher (C.fromSuccess res) G.empty + neo4jEqual 1 (length $ G.getNodes gp) + neo4jBool $ props `elem` map getNodeProperties (G.getNodes gp) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "CREATE (n:Person { props }) RETURN n" + props = M.fromList ["name" |: ("Michael" :: T.Text), "position" |: ("Developer" :: T.Text), + "awesome" |: True, "children" |: (3 :: Int64)] + params = M.fromList [("props", C.ParamProperties props)] + +-- | Test cypher create multiple nodes +case_cypherCreateMultipleNodes :: Assertion +case_cypherCreateMultipleNodes = withConnection host port $ do + res <- C.cypher query params + neo4jBool $ C.isSuccess res + let gp = G.addCypher (C.fromSuccess res) G.empty + neo4jEqual 2 (length $ G.getNodes gp) + neo4jBool $ propsA `elem` map getNodeProperties (G.getNodes gp) + neo4jBool $ propsB `elem` map getNodeProperties (G.getNodes gp) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "CREATE (n:Person { props }) RETURN n" + propsA = M.fromList ["name" |: ("Andres" :: T.Text), "position" |: ("Developer" :: T.Text)] + propsB = M.fromList ["name" |: ("Michael" :: T.Text), "position" |: ("Developer" :: T.Text)] + params = M.fromList [("props", C.ParamPropertiesArray [propsA, propsB])] + +-- | Test cypher set all properties on a node +case_cypherSetAllNodeProperties :: Assertion +case_cypherSetAllNodeProperties = withConnection host port $ do + res <- C.cypher query params + neo4jBool $ C.isSuccess res + let gp = G.addCypher (C.fromSuccess res) G.empty + neo4jEqual 1 (length $ G.getNodes gp) + neo4jBool $ props `elem` map getNodeProperties (G.getNodes gp) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "CREATE (n:Person { name: 'this property is to be deleted' } ) SET n = { props } RETURN n" + props = M.fromList ["name" |: ("Michael" :: T.Text), "position" |: ("Developer" :: T.Text), + "awesome" |: True, "children" |: (3 :: Int64)] + params = M.fromList [("props", C.ParamProperties props)] + +-- | Test cypher basic query +case_cypherBasicQuery :: Assertion +case_cypherBasicQuery = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ do + n1 <- B.createNode $ M.fromList ["name" |: ("I" :: T.Text)] + n2 <- B.createNode $ M.fromList ["name" |: ("you" :: T.Text)] + n3 <- B.createNode $ M.fromList ["name" |: ("him" :: T.Text), "age" |: (25 :: Int64)] + _ <- B.createRelationship "know" M.empty n1 n2 + B.createRelationship "know" M.empty n1 n3 + -- actual test + res <- C.cypher query params + neo4jBool $ C.isSuccess res + neo4jEqual ["type(r)", "n.name", "n.age"] (C.cols $ C.fromSuccess res) + neo4jBool $ ["know", "him", J.Number 25] `elem` (C.vals $ C.fromSuccess res) + neo4jBool $ ["know", "you", J.Null] `elem` (C.vals $ C.fromSuccess res) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (x {name: 'I'})-[r]->(n) RETURN type(r), n.name, n.age" + params = M.empty + +-- | Test cypher basic query get relationships +case_cypherBasicQueryGetRels :: Assertion +case_cypherBasicQueryGetRels = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ do + n1 <- B.createNode $ M.fromList ["name" |: ("I" :: T.Text)] + n2 <- B.createNode $ M.fromList ["name" |: ("you" :: T.Text)] + n3 <- B.createNode $ M.fromList ["name" |: ("him" :: T.Text), "age" |: (25 :: Int64)] + _ <- B.createRelationship "know" M.empty n1 n2 + B.createRelationship "know" M.empty n1 n3 + -- actual test + res <- C.cypher query params + neo4jBool $ C.isSuccess res + let gres = G.addCypher (C.fromSuccess res) G.empty + neo4jBool $ (length $ G.getRelationships gres) >= 2 + neo4jBool $ all (\r -> getRelType r == "know") (G.getRelationships gres) + neo4jEqual ["r"] (C.cols $ C.fromSuccess res) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (x {name: 'I'})-[r]->(n) RETURN r" + params = M.empty + +-- | Test cypher nested results +case_cypherNestedResults :: Assertion +case_cypherNestedResults = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ do + n1 <- B.createNode $ M.fromList ["name" |: ("I" :: T.Text)] + n2 <- B.createNode $ M.fromList ["name" |: ("you" :: T.Text)] + B.createRelationship "know" M.empty n1 n2 + -- actual test + res <- C.cypher query params + neo4jBool $ C.isSuccess res + neo4jEqual ["collect(n.name)"] (C.cols $ C.fromSuccess res) + let v = case (head $ head $ C.vals $ C.fromSuccess res) of + J.Array vec -> vec + _ -> V.empty + neo4jBool $ "you" `V.elem` v + neo4jBool $ "I" `V.elem` v + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (n) WHERE n.name in ['I', 'you'] RETURN collect(n.name)" + params = M.empty + +-- | Test cypher errors +case_cypherError :: Assertion +case_cypherError = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ do + B.createNode $ M.fromList ["age" |: (26 :: Int64)] + -- actual test + res <- C.cypher query params + neo4jBool $ res `elem` [Left "BadInputException", Left "ArithmeticException"] + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (x) WHERE has(x.age) RETURN x.age / 0" + params = M.empty + +-- | Test lone transaction cypher basic query +case_loneTransactionBasicQuery :: Assertion +case_loneTransactionBasicQuery = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ do + n1 <- B.createNode $ M.fromList ["name" |: ("I" :: T.Text)] + n2 <- B.createNode $ M.fromList ["name" |: ("you" :: T.Text)] + n3 <- B.createNode $ M.fromList ["name" |: ("him" :: T.Text), "age" |: (25 :: Int64)] + _ <- B.createRelationship "know" M.empty n1 n2 + B.createRelationship "know" M.empty n1 n3 + -- actual test + res <- TC.loneQuery query params + neo4jBool $ TC.isSuccess res + neo4jEqual ["type(r)", "n.name", "n.age"] (TC.cols $ TC.fromSuccess res) + neo4jBool $ ["know", "him", J.Number 25] `elem` (TC.vals $ TC.fromSuccess res) + neo4jBool $ ["know", "you", J.Null] `elem` (TC.vals $ TC.fromSuccess res) + neo4jEqual TC.emptyStats (TC.stats $ TC.fromSuccess res) + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (x {name: 'I'})-[r]->(n) RETURN type(r), n.name, n.age" + params = M.empty + +-- | Test cypher errors in a transaction +case_cypherTransactionError :: Assertion +case_cypherTransactionError = withConnection host port $ do + -- create initial data + gp <- B.runBatch $ B.createNode $ M.fromList ["age" |: (26 :: Int64)] + -- actual test + res <- TC.loneQuery query params + neo4jEqual (Left ("Neo.ClientError.Statement.ArithmeticError","/ by zero")) res + -- cleanup + _ <- B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + return () + where query = "MATCH (x) WHERE has(x.age) RETURN x.age / 0" + params = M.empty + +-- | Test a cypher transaction +case_cypherTransaction :: Assertion +case_cypherTransaction = withConnection host port $ do + res <- TC.runTransaction $ do + result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + voidIO $ assertEqual "" ["pere", "pau", "p1", "pere.age"] (TC.cols result) + voidIO $ assertEqual "" (TC.Stats True 2 0 2 1 0 2 0 0 0 0 0) (TC.stats result) + let vals = TC.vals result + voidIO $ assertEqual "" 1 (length vals) + voidIO $ assertEqual "" 4 (length $ head vals) + voidIO $ assertEqual "" (J.Number 78.0) (head vals !! 3) + voidIO $ assertEqual "" 1 (length $ TC.graph result) + voidIO $ assertEqual "" 1 (length $ G.getRelationships (head $ TC.graph result)) + voidIO $ assertEqual "" 2 (length $ G.getNodes (head $ TC.graph result)) + return result + neo4jBool $ TC.isSuccess res + let (Right tresult) = res + let gp = head $ TC.graph tresult + void $ B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + void $ B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + where voidIO x = void $ liftIO x + +-- | Test a cypher transaction with a explicit commit +case_cypherTransactionExplicitCommit :: Assertion +case_cypherTransactionExplicitCommit = withConnection host port $ do + res <- TC.runTransaction $ do + result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + void $ TC.cypher "CREATE (pep: PERSON {age: 55})" M.empty + TC.commit + return result + neo4jBool $ TC.isSuccess res + let (Right result) = res + voidIO $ assertEqual "" ["pere", "pau", "p1", "pere.age"] (TC.cols result) + voidIO $ assertEqual "" (TC.Stats True 2 0 2 1 0 2 0 0 0 0 0) (TC.stats result) + let vals = TC.vals result + voidIO $ assertEqual "" 1 (length vals) + voidIO $ assertEqual "" 4 (length $ head vals) + voidIO $ assertEqual "" (J.Number 78.0) (head vals !! 3) + voidIO $ assertEqual "" 1 (length $ TC.graph result) + voidIO $ assertEqual "" 1 (length $ G.getRelationships (head $ TC.graph result)) + voidIO $ assertEqual "" 2 (length $ G.getNodes (head $ TC.graph result)) + let gp = head $ TC.graph result + void $ B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + void $ B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + where voidIO x = void $ liftIO x + +-- | Test a cypher transaction with a keepalive +case_cypherTransactionKeepAlive :: Assertion +case_cypherTransactionKeepAlive = withConnection host port $ do + res <- TC.runTransaction $ do + TC.keepalive + void $ TC.cypher "CREATE (pep: PERSON {age: 55})" M.empty + TC.keepalive + result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + return result + neo4jBool $ TC.isSuccess res + let (Right result) = res + voidIO $ assertEqual "" ["pere", "pau", "p1", "pere.age"] (TC.cols result) + voidIO $ assertEqual "" (TC.Stats True 2 0 2 1 0 2 0 0 0 0 0) (TC.stats result) + let vals = TC.vals result + voidIO $ assertEqual "" 1 (length vals) + voidIO $ assertEqual "" 4 (length $ head vals) + voidIO $ assertEqual "" (J.Number 78.0) (head vals !! 3) + voidIO $ assertEqual "" 1 (length $ TC.graph result) + voidIO $ assertEqual "" 1 (length $ G.getRelationships (head $ TC.graph result)) + voidIO $ assertEqual "" 2 (length $ G.getNodes (head $ TC.graph result)) + let gp = head $ TC.graph result + void $ B.runBatch $ mapM_ B.deleteRelationship (G.getRelationships gp) + void $ B.runBatch $ mapM_ B.deleteNode (G.getNodes gp) + where voidIO x = void $ liftIO x + +-- | Test a cypher transaction with an error +case_cypherErrorInTransaction :: Assertion +case_cypherErrorInTransaction = withConnection host port $ do + res <- TC.runTransaction $ do + -- query with wrong syntax + void $ TC.cypher "i" M.empty + TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + neo4jBool $ not $ TC.isSuccess res + neo4jEqual (Left ("Neo.ClientError.Statement.InvalidSyntax", + "Invalid input 'i': expected (line 1, column 1)\n\"i\"\n ^")) res + +-- | Test a cypher rollback transaction +case_cypherTransactionRollback :: Assertion +case_cypherTransactionRollback = withConnection host port $ do + void $ TC.runTransaction $ do + void $ TC.cypher "CREATE (pepe: PERSON {age: 55})" M.empty + result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + TC.rollback + return result + +-- | Test a cypher rollback and leave transaction +case_cypherTransactionRollbackAndLeave :: Assertion +case_cypherTransactionRollbackAndLeave = withConnection host port $ do + res <- TC.runTransaction $ do + void $ TC.cypher "CREATE (pepe: PERSON {age: 55})" M.empty + result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + TC.rollbackAndLeave "My message" + TC.commit + TC.rollback + return result + neo4jEqual (Left ("Rollback", "My message")) res + +-- | Test issuing a commits after a rollback +case_cypherTransactionEnded :: Assertion +case_cypherTransactionEnded = assertException expException $ withConnection host port $ do + void $ TC.runTransaction $ do + void $ TC.cypher "CREATE (pepe: PERSON {age: 55})" M.empty + result <- TC.cypher "CREATE (pere: PERSON {age: {age}}) CREATE (pau: PERSON {props}) \ + \CREATE p1 = (pere)-[:KNOWS]->(pau) RETURN pere, pau, p1, pere.age" $ + M.fromList [("age", TC.newparam (78 :: Int64)), + ("props", TC.ParamProperties $ M.fromList["age" |: (99 :: Int64)])] + TC.rollback + TC.commit + return result + where expException = TransactionEndedExc + +-- | Test graph union op +case_graphUnion :: Assertion +case_graphUnion = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + void $ B.addLabels ["a"] n1 + _ <- B.createRelationship "type1" someOtherProperties n1 n2 + B.createRelationship "type2" someProperties n2 n1 + g2 <- B.runBatch $ do + n1 <- B.createNode someOtherProperties + n2 <- B.createNode anotherProperties + void $ B.addLabels ["b"] n1 + _ <- B.createRelationship "type1" someOtherProperties n1 n2 + B.createRelationship "type2" someProperties n2 n1 + let g3 = g `G.union` g2 + neo4jEqual 4 (length $ G.getNodes g3) + neo4jEqual 4 (length $ G.getRelationships g3) + neo4jBool $ someOtherProperties `elem` map getRelProperties (G.getRelationships g3) + neo4jBool $ someProperties `elem` map getRelProperties (G.getRelationships g3) + neo4jBool $ someOtherProperties `elem` map getNodeProperties (G.getNodes g3) + neo4jBool $ someProperties `elem` map getNodeProperties (G.getNodes g3) + neo4jBool $ "type1" `elem` map getRelType (G.getRelationships g3) + neo4jBool $ "type2" `elem` map getRelType (G.getRelationships g3) + neo4jBool $ "a" `elem` (join $ map (HS.toList . (flip G.getNodeLabels g3)) (G.getNodes g3)) + neo4jBool $ "b" `elem` (join $ map (HS.toList . (flip G.getNodeLabels g3)) (G.getNodes g3)) + mapM_ deleteRelationship (G.getRelationships g3) + mapM_ deleteNode (G.getNodes g3) + +-- | Test graph difference op +case_graphDifference :: Assertion +case_graphDifference = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + void $ B.addLabels ["a"] n1 + _ <- B.createRelationship "type1" someOtherProperties n1 n2 + B.createRelationship "type2" someProperties n2 n1 + let g2 = g `G.difference` g + neo4jEqual 0 (length $ G.getRelationships g2) + neo4jEqual 0 (length $ G.getNodes g2) + let subGraph = G.deleteNode (head $ G.getNodes g) g + let g3 = g `G.difference` (G.deleteRelationship (head $ G.getRelationships subGraph) subGraph) + neo4jEqual 1 (length $ G.getRelationships g3) + neo4jEqual 1 (length $ G.getNodes g3) + +-- | Test graph intersection op +case_graphIntersection :: Assertion +case_graphIntersection = withConnection host port $ do + g <- B.runBatch $ do + n1 <- B.createNode someProperties + n2 <- B.createNode anotherProperties + void $ B.addLabels ["a"] n1 + _ <- B.createRelationship "type1" someOtherProperties n1 n2 + B.createRelationship "type2" someProperties n2 n1 + g2 <- B.runBatch $ do + B.createNode someProperties + let g3 = G.addNode (head $ G.getNodes g) g2 + let g4 = g `G.intersection` (G.addRelationship (head $ G.getRelationships g) g3) + neo4jEqual 1 (length $ G.getRelationships g4) + neo4jEqual 1 (length $ G.getNodes g4) + neo4jEqual (head $ G.getRelationships g) (head $ G.getRelationships g4) + neo4jEqual (head $ G.getNodes g) (head $ G.getNodes g4)