version 0.0.0.15: upd get and put on graphs (#22)

* put updated

* 0.0.0.15: upd get in graphs

* example added

CHANGELOG.md

@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
 
 ## [Unreleased]
 
+## [0.0.0.15] - 2019-01-22
+### Changed
+- Ability to choose whether to return entity or not in graphs.
+
 ## [0.0.0.14] - 2018-12-25
 ### Added
 - `mergeGraphs`, ability to take not all node properties from DB.

example/Main.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Main where
+
+import           Control.Exception             (bracket)
+import           Control.Monad.State           (execState, modify)
+import           Data.Aeson                    (encode)
+import qualified Data.ByteString.Lazy.Char8    as B (putStrLn)
+import           Data.Default                  (def)
+import           Data.Map.Strict               ((!))
+import           Data.Text                     (Text)
+import           Database.Bolt                 (BoltActionT, BoltCfg (..),
+                                                Value (..), close, connect, run)
+import           Database.Bolt.Extras          (NodeLike (..),
+                                                URelationLike (..))
+import           Database.Bolt.Extras.Graph
+import           Database.Bolt.Extras.Template (makeNodeLike, makeURelationLike)
+import           GHC.Generics                  (Generic)
+
+-- | Configuration for connection to local database.
+boltCfg :: BoltCfg
+boltCfg = def { host = "localhost"
+              , user = "neo4j"
+              , password = "12345"
+              }
+
+-- | Helper to run queries in Neo4j DB.
+--
+runQueryDB :: BoltActionT IO a -> IO a
+runQueryDB act = bracket (connect boltCfg) close (`run` act)
+
+data ExampleNode = ExampleNode { exampleFieldT :: Text
+                               , exampleFieldI :: Int
+                               }
+  deriving (Show, Generic)
+
+data EXAMPLE_RELATION = EXAMPLE_RELATION
+  deriving (Show, Generic)
+
+makeNodeLike ''ExampleNode
+makeURelationLike ''EXAMPLE_RELATION
+
+exNodeAVar :: Text
+exNodeAVar = "nodeA"
+
+exNodeBVar :: Text
+exNodeBVar = "nodeB"
+
+-- | Builds query:
+-- CREATE (nodeA:ExampleNode { exampleFieldT: "A" , exampleFieldI: 1}) WITH nodeA
+-- MERGE  (nodeB:ExampleNode { exampleFieldT: "B" , exampleFieldI: 2}) WITH nodeB
+-- MERGE  (nodeA)-[nodeA0nodeB:EXAMPLE_RELATION]-(nodeB) WITH nodeA, nodeB, nodeA0nodeB
+-- RETURN ID(nodeA), ID(nodeB), ID(nodeA0nodeB)
+--
+examplePutGraph :: GraphPutRequest
+examplePutGraph = flip execState emptyGraph $ do
+    modify $ addNode exNodeAVar (CreateN . toNode $ exNodeA)
+    modify $ addNode exNodeBVar (MergeN  . toNode $ exNodeB)
+
+    modify $ addRelation exNodeAVar exNodeBVar (MergeR . toURelation $ exRel)
+  where
+    exNodeA = ExampleNode "A" 1
+    exNodeB = ExampleNode "B" 2
+    exRel   = EXAMPLE_RELATION
+
+-- | Builds query:
+-- MATCH (nodeA)-[:EXAMPLE_RELATION]-(nodeB),
+-- (nodeA:ExampleNode { exampleField: "A" }),
+-- (nodeB:ExampleNode { exampleField: "B" })
+-- RETURN { id: ID(nodeA), labels: labels(nodeA), props: properties(nodeA) }
+--
+exampleGetGraphB :: GraphGetRequest
+exampleGetGraphB = flip execState emptyGraph $ do
+    modify $ addNode exNodeAVar exNodeA
+    modify $ addNode exNodeBVar exNodeB
+
+    modify $ addRelation exNodeAVar exNodeBVar exRel
+  where
+    exNodeA = defaultNodeReturn    # withLabelQ ''ExampleNode
+                                   # withProp   ("exampleFieldT", T "A")
+                                   # withReturn allProps
+
+    exNodeB = defaultNodeNotReturn # withLabelQ ''ExampleNode
+                                   # withProp   ("exampleFieldT", T "B")
+
+    exRel   = defaultRelNotReturn  # withLabelQ ''EXAMPLE_RELATION
+
+-- | Builds query:
+-- MATCH (nodeA:ExampleNode { exampleField: "A" })
+-- RETURN { id: ID(nodeA), labels: labels(nodeA), props: nodeA {.exampleFieldI} }
+--
+exampleGetGraphA :: GraphGetRequest
+exampleGetGraphA = flip execState emptyGraph $
+    modify $ addNode exNodeAVar exNodeA
+  where
+    exNodeA = defaultNodeReturn    # withLabelQ ''ExampleNode
+                                   # withProp   ("exampleFieldT", T "A")
+                                   # withReturn ["exampleFieldI"]
+
+-- | Put 'examplePutGraph' to the database.
+--
+putGraph :: IO ()
+putGraph = do
+    putGraphR <- runQueryDB $ makeRequest @PutRequestB [] examplePutGraph
+    putStrLn "Uploaded graph: "
+    print putGraphR
+
+-- Get 'exampleGetGraphB' and parse it to Haskell object.
+--
+getGraphB :: IO ()
+getGraphB = do
+    getGraphsR                  <- runQueryDB $ makeRequest @GetRequestB [] exampleGetGraphB
+    let nodesA :: [ExampleNode] = fromNode . (! exNodeAVar) . _vertices <$> getGraphsR
+    putStrLn "Downloaded graph and converted to Haskell object: "
+    print nodesA
+
+-- Get 'exampleGetGraphA' and parse it to JSON.
+--
+getGraphA :: IO ()
+getGraphA = do
+    getGraphsR <- runQueryDB $ makeRequest @GetRequestA [] exampleGetGraphA
+    let nodesA = (! exNodeAVar) . _vertices <$> getGraphsR
+    putStrLn "Downloaded graph and converted to JSON: "
+    B.putStrLn . encode $ nodesA
+
+main :: IO ()
+main = putGraph >> getGraphB >> getGraphA

hasbolt-extras.cabal

@@ -1,5 +1,5 @@
 name:           hasbolt-extras
-version:        0.0.0.14
+version:        0.0.0.15
 synopsis:       Extras for hasbolt library
 description:    Extras for hasbolt library
 homepage:       https://github.com/biocad/hasbolt-extras#readme
@@ -64,3 +64,18 @@ library
                      , unordered-containers
   ghc-options:     -Wall -O2
   default-language: Haskell2010
+
+executable example
+  hs-source-dirs:      example
+  main-is:             Main.hs
+  build-depends:       base >= 4.7 && < 5
+                     , aeson
+                     , bytestring
+                     , containers
+                     , data-default
+                     , hasbolt
+                     , hasbolt-extras
+                     , mtl
+                     , text
+  default-language:    Haskell2010
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -O2

src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module Database.Bolt.Extras.Graph.Internal.AbstractGraph
   (
@@ -8,18 +10,23 @@ module Database.Bolt.Extras.Graph.Internal.AbstractGraph
   , emptyGraph
   , addNode
   , addRelation
+  , NodeName
+  , relationName
   ) where
 
 import           Control.Lens    (makeLenses, over)
 import           Data.Map.Strict (Map, insert, notMember)
+import           Data.Monoid     ((<>))
+import           Data.Text       (Text)
+import           GHC.Generics    (Generic)
 import           Text.Printf     (printf)
 
 -- | 'Graph' contains vertices, that are parameterized by some type @n@, and relations,
 -- that parameterized by pair of type @n@. This pair represents vertices, that are connected with this relation.
 --
 data Graph n a b = Graph { _vertices  :: Map n a
                          , _relations :: Map (n, n) b
-                         } deriving (Show)
+                         } deriving (Show, Generic)
 
 makeLenses ''Graph
 
@@ -43,3 +50,12 @@ addRelation :: (Show n, Ord n) => n -> n -> b -> Graph n a b -> Graph n a b
 addRelation startName endName rel graph = if (startName, endName) `notMember` _relations graph
                                           then over relations (insert (startName, endName) rel) graph
                                           else error $ printf "relation with names (%s, %s) already exists" (show startName) (show endName)
+
+-- | Alias for text node name.
+--
+type NodeName = Text
+
+-- | Creates relationship name from the names of its start and end nodes
+-- in the way `<startNodeName>0<endNodeName>`.
+relationName :: (NodeName, NodeName) -> Text
+relationName (st, en) = st <> "0" <> en

src/Database/Bolt/Extras/Graph/Internal/Class.hs

@@ -12,14 +12,15 @@ import           Database.Bolt          (BoltActionT, Record)
 -- | Class describes entity, which can be requested.
 --
 class Requestable a where
-  -- | Condition for BoltId like "ID(a) = b" if BoltId is presented.
-  maybeBoltIdCond :: a -> Maybe Text
   -- | How to convert entity to Cypher.
   request         :: a -> Text
 
 -- | Class describes entity, which can be returned.
 --
 class Returnable a where
+  -- | If the entity should be returned.
+  isReturned' :: a -> Bool
+
   -- | How to return entity in the Cypher.
   return' :: a -> Text