{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Bolt.Extras.Graph.Internal.Get ( -- * Types for requesting nodes and relationships NodeGetter (..) , RelGetter (..) , GetterLike (..) , (#) , defaultNode , defaultRel , defaultNodeReturn , defaultNodeNotReturn , defaultRelReturn , defaultRelNotReturn , requestGetters , allProps -- * Types for extracting nodes and relationships , NodeResult (..) , RelResult (..) , relationName -- * Graph types , GraphGetRequest , GraphGetResponse -- * Helpers to extract entities from result graph , extractNode , extractRelation , extractNodeId , extractRelationId , extractNodeAeson , extractRelationAeson ) where import Control.Lens (at, non, to, (^.)) import Control.Monad.IO.Class (MonadIO) import Data.Aeson as A (FromJSON (..), Result (..), ToJSON (..), Value, fromJSON, genericParseJSON, genericToJSON, omitNothingFields, toJSON) import Data.Aeson.Casing (aesonPrefix, snakeCase) import Data.Function ((&)) import Data.Map.Strict as M (Map, filter, fromList, insert, toList, (!)) import Data.Maybe (catMaybes, fromJust, isJust) import Data.Monoid ((<>)) import Data.Text (Text, cons, intercalate, pack, unpack) import Database.Bolt as B (BoltActionT, Node (..), Record, URelationship (..), Value) import Database.Bolt.Extras (BoltId, GetBoltId (..), Label, NodeLike (..), ToCypher (..), URelationLike (..)) import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph, NodeName, relationName, relations, vertices) import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..), Requestable (..), Returnable (..)) import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Name, nameBase) import NeatInterpolation (text) import Text.Printf (printf) ---------------------------------------------------------- -- REQUEST -- ---------------------------------------------------------- -- | Helper to find 'Node's. -- data NodeGetter = NodeGetter { ngboltId :: Maybe BoltId -- ^ known boltId , ngLabels :: [Label] -- ^ known labels , ngProps :: Map Text B.Value -- ^ known properties , ngReturnProps :: [Text] -- ^ names of properties to return , ngIsReturned :: Bool -- ^ whether return this node or not } deriving (Show, Eq) -- | Helper to find 'URelationship's. -- data RelGetter = RelGetter { rgboltId :: Maybe BoltId -- ^ known boltId , rgLabel :: Maybe Label -- ^ known labels , rgProps :: Map Text B.Value -- ^ known properties , rgReturnProps :: [Text] -- ^ names of properties to return , rgIsReturned :: Bool -- ^ whether return this relation or not } deriving (Show, Eq) (#) :: a -> (a -> b) -> b (#) = (&) defaultNode :: Bool -> NodeGetter defaultNode = NodeGetter Nothing [] (fromList []) [] defaultRel :: Bool -> RelGetter defaultRel = RelGetter Nothing Nothing (fromList []) [] defaultNodeReturn :: NodeGetter defaultNodeReturn = defaultNode True defaultNodeNotReturn :: NodeGetter defaultNodeNotReturn = defaultNode False defaultRelReturn :: RelGetter defaultRelReturn = defaultRel True defaultRelNotReturn :: RelGetter defaultRelNotReturn = defaultRel False -- | Helper to work with Getters. -- class GetterLike a where withBoltId :: BoltId -> a -> a -- ^ set known boltId withLabel :: Label -> a -> a -- ^ set known label withLabelQ :: Name -> a -> a -- ^ set known label as 'Name' withProp :: (Text, B.Value) -> a -> a -- ^ add known property withReturn :: [Text] -> a -> a -- ^ add list of properties to return isReturned :: a -> a -- ^ set that current node should be returned instance GetterLike NodeGetter where withBoltId boltId ng = ng { ngboltId = Just boltId } withLabel lbl ng = ng { ngLabels = lbl : ngLabels ng } withLabelQ lblQ = withLabel (pack . nameBase $ lblQ) withProp (pk, pv) ng = ng { ngProps = insert pk pv (ngProps ng) } withReturn props ng = ng { ngReturnProps = ngReturnProps ng ++ props } isReturned ng = ng { ngIsReturned = True } instance GetterLike RelGetter where withBoltId boltId rg = rg { rgboltId = Just boltId } withLabel lbl rg = rg { rgLabel = Just lbl } withLabelQ lblQ = withLabel (pack . nameBase $ lblQ) withProp (pk, pv) rg = rg { rgProps = insert pk pv (rgProps rg) } withReturn props rg = rg { rgReturnProps = rgReturnProps rg ++ props } isReturned rg = rg { rgIsReturned = True } instance Requestable (NodeName, NodeGetter) where request (name, ng) = [text|($name $labels $propsQ)|] where labels = toCypher . ngLabels $ ng propsQ = "{" <> (toCypher . toList . ngProps $ ng) <> "}" instance Requestable ((NodeName, NodeName), RelGetter) where request ((stName, enName), rg) = [text|($stName)-[$name $typeQ $propsQ]-($enName)|] where name = relationName (stName, enName) typeQ = maybe "" toCypher (rgLabel rg) propsQ = "{" <> (toCypher . toList . rgProps $ rg) <> "}" instance Returnable (NodeName, NodeGetter) where isReturned' (_, ng) = ngIsReturned ng return' (name, ng) = let showProps = showRetProps name $ ngReturnProps ng in [text|{ id: id($name), labels: labels($name), props: $showProps } as $name |] instance Returnable ((NodeName, NodeName), RelGetter) where isReturned' (_, rg) = rgIsReturned rg return' ((stName, enName), rg) = let name = relationName (stName, enName) showProps = showRetProps name $ rgReturnProps rg in [text|{ id: id($name), label: type($name), props: $showProps } as $name |] allProps :: [Text] allProps = ["*"] showRetProps :: Text -> [Text] -> Text showRetProps name [] = name <> "{}" showRetProps name ["*"] = "properties(" <> name <> ")" showRetProps name props = name <> "{" <> intercalate ", " (cons '.' <$> props) <> "}" -- | Takes all node getters and relationship getters -- and write them to single query to request. -- Also return conditions on known boltId-s. -- requestGetters :: [(NodeName, NodeGetter)] -> [((NodeName, NodeName), RelGetter)] -> (Text, [Text]) requestGetters ngs rgs = ("MATCH " <> intercalate ", " (fmap request rgs ++ fmap request ngs), conditionsID) where boltIdCondN :: (NodeName, NodeGetter) -> Maybe Text boltIdCondN (name, ng) = pack . printf "ID(%s)=%d" name <$> ngboltId ng boltIdCondR :: ((NodeName, NodeName), RelGetter) -> Maybe Text boltIdCondR (names, rg) = pack . printf "ID(%s)=%d" (relationName names) <$> rgboltId rg conditionsID = catMaybes (fmap boltIdCondN ngs ++ fmap boltIdCondR rgs) ---------------------------------------------------------- -- RESULT -- ---------------------------------------------------------- -- | Result for node in the Aeson like format. -- data NodeResult = NodeResult { nresId :: BoltId , nresLabels :: [Label] , nresProps :: Map Text A.Value } deriving (Show, Eq, Generic) -- | Result for relationship in the Aeson like format. -- data RelResult = RelResult { rresId :: BoltId , rresLabel :: Label , rresProps :: Map Text A.Value } deriving (Show, Eq, Generic) instance GetBoltId NodeResult where getBoltId = nresId instance GetBoltId RelResult where getBoltId = rresId instance ToJSON NodeResult where toJSON = genericToJSON (aesonPrefix snakeCase) { omitNothingFields = True } instance FromJSON NodeResult where parseJSON = genericParseJSON (aesonPrefix snakeCase) { omitNothingFields = True } instance ToJSON RelResult where toJSON = genericToJSON (aesonPrefix snakeCase) { omitNothingFields = True } instance FromJSON RelResult where parseJSON = genericParseJSON (aesonPrefix snakeCase) { omitNothingFields = True } instance Extractable NodeResult where extract = extractFromJSON instance Extractable RelResult where extract = extractFromJSON extractFromJSON :: (MonadIO m, FromJSON a) => Text -> [Record] -> BoltActionT m [a] extractFromJSON var = pure . fmap (\r -> case fromJSON (toJSON (r ! var)) of Success parsed -> parsed Error err -> error err) fromJSONM :: forall a. FromJSON a => A.Value -> Maybe a fromJSONM (fromJSON -> Success r :: Result a) = Just r fromJSONM _ = Nothing instance NodeLike NodeResult where toNode NodeResult{..} = Node nresId nresLabels (fromJust <$> M.filter isJust (fromJSONM <$> nresProps)) fromNode Node{..} = NodeResult nodeIdentity labels (toJSON <$> nodeProps) instance URelationLike RelResult where toURelation RelResult{..} = URelationship rresId rresLabel (fromJust <$> M.filter isJust (fromJSONM <$> rresProps)) fromURelation URelationship{..} = RelResult urelIdentity urelType (toJSON <$> urelProps) ---------------------------------------------------------- -- GRAPH -- ---------------------------------------------------------- -- | The combinations of 'Getter's to load graph from the database. -- type GraphGetRequest = Graph NodeName NodeGetter RelGetter -- | The graph of 'Node's and 'URelationship's which we got from the database using 'GraphGetRequest'. -- type GraphGetResponse = Graph NodeName NodeResult RelResult -- | Some helpers to extract entities from the result graph. extractNode :: NodeLike a => NodeName -> GraphGetResponse -> a extractNode var graph = graph ^. vertices . at var . non (errorForNode var) . to (fromNode . toNode) extractRelation :: URelationLike a => NodeName -> NodeName -> GraphGetResponse -> a extractRelation stVar enVar graph = graph ^. relations . at (stVar, enVar) . non (errorForRelation stVar enVar) . to (fromURelation . toURelation) extractNodeId :: NodeName -> GraphGetResponse -> BoltId extractNodeId var graph = graph ^. vertices . at var . non (errorForNode var) . to nresId extractRelationId :: NodeName -> NodeName -> GraphGetResponse -> BoltId extractRelationId stVar enVar graph = graph ^. relations . at (stVar, enVar) . non (errorForRelation stVar enVar) . to rresId extractNodeAeson :: NodeName -> GraphGetResponse -> NodeResult extractNodeAeson var graph = graph ^. vertices . at var . non (errorForNode var) extractRelationAeson :: NodeName -> NodeName -> GraphGetResponse -> RelResult extractRelationAeson stVar enVar graph = graph ^. relations . at (stVar, enVar) . non (errorForRelation stVar enVar) errorForNode :: NodeName -> a errorForNode name = error . unpack $ "node with name " <> name <> " doesn't exist" errorForRelation :: NodeName -> NodeName -> a errorForRelation stName enName = error . unpack $ "relation between nodes " <> stName <> " and " <> enName <> " doesn't exist"