diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ ## [Unreleased] +## [0.0.0.6] - 2018-04-20 +### Added +- Added ability to update properties of the existing node; added ability to choose +if you want to `CREATE` or `MERGE` the relationship. + ## [0.0.0.4] - 2018-04-05 ### Changed - More accurate `toNode` on data fields with `Maybe a` type. If the corresponding field in the type is Nothing, this field won't be included to `Node`. diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal --- a/hasbolt-extras.cabal +++ b/hasbolt-extras.cabal @@ -1,5 +1,5 @@ name: hasbolt-extras -version: 0.0.0.4 +version: 0.0.0.6 synopsis: Extras for hasbolt library description: Extras for hasbolt library homepage: https://github.com/biocad/hasbolt-extras#readme @@ -24,6 +24,7 @@ library hs-source-dirs: src exposed-modules: Database.Bolt.Extras + , Database.Bolt.Extras.Condition , Database.Bolt.Extras.Graph , Database.Bolt.Extras.Persisted , Database.Bolt.Extras.Query @@ -31,6 +32,7 @@ , Database.Bolt.Extras.Utils other-modules: Database.Bolt.Extras.Query.Get , Database.Bolt.Extras.Query.Put + , Database.Bolt.Extras.Query.Set , Database.Bolt.Extras.Query.Utils Database.Bolt.Extras.Query.Cypher diff --git a/src/Database/Bolt/Extras/Condition.hs b/src/Database/Bolt/Extras/Condition.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Condition.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Database.Bolt.Extras.Condition + ( + Condition (..) + , tautology + , matches + , itself + ) where + +-- | Conditional expressions over type 'a' and its mappings. +-- Supported operations: +-- * equality check :== +-- * disunction :&& +-- * conjunction :|| +-- +-- Typical usage: +-- Say we have variable 'var :: a', a function 'f :: a -> b' and a value 'val :: b'. +-- Expression 'f :== b' acts as 'f a == b' +-- Examples: +-- +-- > data D = D { fld1 :: Int +-- > , fld2 :: String +-- > , fld3 :: Double +-- > } +-- > +-- > d = D 42 "noononno" 1.618 +-- > d `matches` (fld1 :== 12 :&& fld2 :== "abc") +-- > False +-- > +-- > d `matches` (fld1 :== 42 :|| fld3 == 1.0) +-- > True +-- +infix 4 :== +infixr 3 :&& +infixr 2 :|| +data Condition a = forall b. Eq b => (a -> b) :== b + | Condition a :&& Condition a + | Condition a :|| Condition a + + +-- | Check whether data satisfies conditions on it. +-- +matches :: a -> Condition a -> Bool +matches obj (transform :== ref) = transform obj == ref +matches obj (u :&& v) = matches obj u && matches obj v +matches obj (u :|| v) = matches obj u || matches obj v + + +-- | Matching 'tautology' will always succeed. +-- > whatever `matches` tautology == True +-- > -- Match is lazy: +-- > undefined `matches` tautology == True +-- +tautology :: Condition a +tautology = const True :== True + + +-- | Object itself instead of its mappings is matched with help of this alias. +-- > 42 `matches` (itself :== 42) == True +-- > 42 `matches` (itself :== 41) == False +-- +itself :: a -> a +itself = id diff --git a/src/Database/Bolt/Extras/Query.hs b/src/Database/Bolt/Extras/Query.hs --- a/src/Database/Bolt/Extras/Query.hs +++ b/src/Database/Bolt/Extras/Query.hs @@ -6,10 +6,12 @@ , NodeGetter (..) , NodeName , PutNode (..) + , PutRelationship (..) , RelGetter (..) , ToCypher (..) , getGraph , putGraph + , setNode ) where import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) @@ -19,5 +21,8 @@ RelGetter (..), getGraph) import Database.Bolt.Extras.Query.Put (GraphPutRequest, GraphPutResponse, - PutNode (..), putGraph) + PutNode (..), + PutRelationship (..), + putGraph) +import Database.Bolt.Extras.Query.Set (setNode) import Database.Bolt.Extras.Query.Utils (NodeName) diff --git a/src/Database/Bolt/Extras/Query/Cypher.hs b/src/Database/Bolt/Extras/Query/Cypher.hs --- a/src/Database/Bolt/Extras/Query/Cypher.hs +++ b/src/Database/Bolt/Extras/Query/Cypher.hs @@ -15,13 +15,12 @@ -- This file contains some converation rules from 'Database.Bolt' types to `Cypher`. ------------------------------------------------------------------------------------------------- -import Data.Text as T (Text, concat, cons, - intercalate, pack, - toUpper) -import Database.Bolt (Value (..)) -import Database.Bolt.Extras.Template (Label, Property) -import Database.Bolt.Extras.Utils (currentLoc) -import NeatInterpolation (text) +import Data.Text as T (Text, concat, cons, + intercalate, pack, toUpper) +import Database.Bolt (Value (..)) +import Database.Bolt.Extras.Template (Label, Property) +import Database.Bolt.Extras.Utils (currentLoc) +import NeatInterpolation (text) -- | The class for convertation into Cypher. -- diff --git a/src/Database/Bolt/Extras/Query/Get.hs b/src/Database/Bolt/Extras/Query/Get.hs --- a/src/Database/Bolt/Extras/Query/Get.hs +++ b/src/Database/Bolt/Extras/Query/Get.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} module Database.Bolt.Extras.Query.Get ( NodeGetter (..) @@ -9,6 +8,8 @@ , GraphGetResponse , RelGetter (..) , getGraph + , nodeAsText + , condIdAsText ) where import Control.Monad.IO.Class (MonadIO) diff --git a/src/Database/Bolt/Extras/Query/Put.hs b/src/Database/Bolt/Extras/Query/Put.hs --- a/src/Database/Bolt/Extras/Query/Put.hs +++ b/src/Database/Bolt/Extras/Query/Put.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} module Database.Bolt.Extras.Query.Put ( GraphPutRequest , GraphPutResponse , PutNode (..) + , PutRelationship (..) , putGraph ) where @@ -16,9 +16,10 @@ import qualified Data.Map.Strict as M (map) import qualified Data.Text as T (Text, pack) import Database.Bolt (BoltActionT, Node (..), - RecordValue (..), Value (..), - URelationship (..), at, - exact, query) + RecordValue (..), + URelationship (..), + Value (..), at, exact, + query) import Database.Bolt.Extras.Graph (Graph (..)) import Database.Bolt.Extras.Persisted (BoltId, fromInt) import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) @@ -27,12 +28,17 @@ -- | 'PutNode' is the wrapper for 'Node' where we can specify if we want to merge or create it. -- -data PutNode = BoltId BoltId | Merge Node | Create Node +data PutNode = BoltId BoltId | MergeN Node | CreateN Node deriving (Show) +-- | 'PutRelationship' is the wrapper for 'Relationship' where we can specify if we want to merge or create it. +-- +data PutRelationship = MergeR URelationship | CreateR URelationship + deriving (Show) + -- | The graph of 'Node's with specified uploading type and 'URelationship's. -- -type GraphPutRequest = Graph NodeName PutNode URelationship +type GraphPutRequest = Graph NodeName PutNode PutRelationship -- | The graph of 'BoltId's corresponding to the nodes and relationships -- which we get after putting 'GraphPutRequest'. @@ -49,9 +55,9 @@ -- putNode :: (MonadIO m) => PutNode -> BoltActionT m [BoltId] putNode ut = case ut of - (BoltId bId) -> pure [bId] - (Merge node) -> helper (T.pack "MERGE") node - (Create node) -> helper (T.pack "CREATE") node + (BoltId bId) -> pure [bId] + (MergeN node) -> helper (T.pack "MERGE") node + (CreateN node) -> helper (T.pack "CREATE") node where helper :: (MonadIO m) => T.Text -> Node -> BoltActionT m [BoltId] helper q node = do @@ -72,23 +78,28 @@ -- For given starting and ending 'Node's 'BoltId's, and for @URelationship _ urelType urelProps@ -- this method makes MERGE query and then returns the corresponding 'BoltId'. -- -putRelationship :: (MonadIO m) => BoltId -> URelationship -> BoltId -> BoltActionT m BoltId -putRelationship start URelationship{..} end = do - [record] <- query mergeQ - urelIdentity' <- record `at` varQ >>= exact - pure $ fromInt urelIdentity' +putRelationship :: (MonadIO m) => BoltId -> PutRelationship -> BoltId -> BoltActionT m BoltId +putRelationship start pr end = case pr of + (MergeR relationship) -> helper (T.pack "MERGE") relationship + (CreateR relationship) -> helper (T.pack "CREATE") relationship where - varQ = "r" - labelQ = toCypher urelType - propsQ = toCypher . toList $ urelProps - startT = T.pack . show $ start - endT = T.pack . show $ end + helper :: (MonadIO m) => T.Text -> URelationship -> BoltActionT m BoltId + helper q URelationship{..} = do + [record] <- query putQuery + urelIdentity' <- record `at` varQ >>= exact + pure $ fromInt urelIdentity' + where + varQ = "r" + labelQ = toCypher urelType + propsQ = toCypher . toList $ urelProps + startT = T.pack . show $ start + endT = T.pack . show $ end - mergeQ :: T.Text - mergeQ = [text|MATCH (a), (b) - WHERE ID(a) = $startT AND ID(b) = $endT - MERGE (a)-[$varQ $labelQ {$propsQ}]->(b) - RETURN ID($varQ) as $varQ|] + putQuery :: T.Text + putQuery = [text|MATCH (a), (b) + WHERE ID(a) = $startT AND ID(b) = $endT + $q (a)-[$varQ $labelQ {$propsQ}]->(b) + RETURN ID($varQ) as $varQ|] -- | Creates graph using given 'GraphPutRequest'. -- If there were multiple choices while merging given _vertices, the first match is used for connection. diff --git a/src/Database/Bolt/Extras/Query/Set.hs b/src/Database/Bolt/Extras/Query/Set.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Query/Set.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Database.Bolt.Extras.Query.Set + ( + setNode + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text, append, intercalate) +import Database.Bolt (BoltActionT, + RecordValue (..), at, + exact, query) +import Database.Bolt.Extras.Persisted (BoltId, fromInt) +import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) +import Database.Bolt.Extras.Query.Get (NodeGetter, condIdAsText, + nodeAsText) +import Database.Bolt.Extras.Template.Types (Property) +import NeatInterpolation (text) + +-- | 'setNode' updates properties for the node, +-- corresponding to the given 'NodeGetter'. +-- +setNode :: (MonadIO m) => NodeGetter -> [Property] -> BoltActionT m BoltId +setNode nodeGetter props = do + let nodeGetterT = nodeAsText (varQ, nodeGetter) + let condId = condIdAsText (varQ, nodeGetter) + + let newProperties = intercalate ", " $ fmap formPropertySet props + + let getQuery = [text|MATCH $nodeGetterT + WHERE $condId + SET $newProperties + RETURN ID($varQ) as $varQ|] + + record <- head <$> query getQuery + nodeIdentity' <- record `at` varQ >>= exact + pure $ fromInt nodeIdentity' + + where + varQ = "n" + + formPropertyName :: Text -> Text + formPropertyName n = varQ `append` "." `append` n + + formPropertySet :: Property -> Text + formPropertySet (name, prop) = formPropertyName name `append` "=" `append` toCypher prop