hasbolt-extras-0.0.0.16: src/Database/Bolt/Extras/Graph/Internal/Get.hs
{-# 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"