{-# 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
(
NodeGetter (..)
, RelGetter (..)
, GetterLike (..)
, (#)
, defaultNode
, defaultRel
, defaultNodeReturn
, defaultNodeNotReturn
, defaultRelReturn
, defaultRelNotReturn
, requestGetters
, allProps
, NodeResult (..)
, RelResult (..)
, relationName
, GraphGetRequest
, GraphGetResponse
, 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)
data NodeGetter = NodeGetter { ngboltId :: Maybe BoltId
, ngLabels :: [Label]
, ngProps :: Map Text B.Value
, ngReturnProps :: [Text]
, ngIsReturned :: Bool
}
deriving (Show, Eq)
data RelGetter = RelGetter { rgboltId :: Maybe BoltId
, rgLabel :: Maybe Label
, rgProps :: Map Text B.Value
, rgReturnProps :: [Text]
, rgIsReturned :: Bool
}
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
class GetterLike a where
withBoltId :: BoltId -> a -> a
withLabel :: Label -> a -> a
withLabelQ :: Name -> a -> a
withProp :: (Text, B.Value) -> a -> a
withReturn :: [Text] -> a -> a
isReturned :: a -> a
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) <> "}"
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)
data NodeResult = NodeResult { nresId :: BoltId
, nresLabels :: [Label]
, nresProps :: Map Text A.Value
}
deriving (Show, Eq, Generic)
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)
type GraphGetRequest = Graph NodeName NodeGetter RelGetter
type GraphGetResponse = Graph NodeName NodeResult RelResult
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"