module Database.Neo4j.Traversal (
Uniqueness(..), TraversalOrder(..), ReturnFilter(..), RelFilter, TraversalDesc(..),
TraversalPaging(..),
ConcreteDirection(..), Path(..), IdPath, FullPath,
PagedTraversal, pathNodes, pathRels,
traverseGetNodes, traverseGetRels, traverseGetPath, traverseGetFullPath,
pagedTraverseGetNodes, pagedTraverseGetRels, pagedTraverseGetPath, pagedTraverseGetFullPath,
getPagedValues, nextTraversalPage, pagedTraversalDone) where
import Data.Default
import Prelude hiding (traverse)
import Control.Applicative
import Control.Exception.Base (throw, catch)
import Control.Monad (mzero)
import Data.Aeson ((.=), (.:), (.:?))
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Types as HT
import qualified Network.URI as NU
import Database.Neo4j.Types
import Database.Neo4j.Http
data Uniqueness = NodeGlobal | RelationshipGlobal | NodePathUnique | RelationshipPath deriving (Eq, Show)
data TraversalOrder = BreadthFirst | DepthFirst deriving (Eq, Show)
data ReturnFilter = ReturnAll | ReturnAllButStartNode deriving (Eq, Show)
type RelFilter = (RelationshipType, Direction)
newtype RelFilterT = RelFilterT {runRelFilter :: RelFilter}
newtype MaybeUniqueness = MaybeUniqueness {runMaybeUniqueness :: Maybe Uniqueness}
data TraversalDesc = TraversalDesc {
travOrder :: TraversalOrder,
travRelFilter :: [RelFilter],
travUniqueness :: Maybe Uniqueness,
travDepth :: Either Integer T.Text,
travNodeFilter :: Either ReturnFilter T.Text} deriving (Eq, Show)
traversalReqBody :: TraversalDesc -> L.ByteString
traversalReqBody (TraversalDesc ord relfilt uniq depth nodefilt) = J.encode $ J.object [
"order" .= J.toJSON ord,
"relationships" .= map RelFilterT relfilt,
"uniqueness" .= MaybeUniqueness uniq,
depthField depth,
"return_filter" .= returnField nodefilt
]
where depthField (Left lvl) = "max_depth" .= lvl
depthField (Right desc) = "prune_evaluator" .= J.object ["language" .= ("javascript" :: T.Text),
"body" .= desc]
returnField (Left filt) = J.object ["language" .= ("builtin" :: T.Text), "name" .= filt]
returnField (Right desc) = J.object ["language" .= ("javascript" :: T.Text), "body" .= desc]
instance J.ToJSON TraversalOrder where
toJSON BreadthFirst = J.String "breadth_first"
toJSON DepthFirst = J.String "depth_first"
instance J.ToJSON ReturnFilter where
toJSON ReturnAll = J.String "all"
toJSON ReturnAllButStartNode = J.String "all_but_start_node"
instance J.ToJSON RelFilterT where
toJSON (RelFilterT (rType, dir)) = J.object ["direction" .= dirToJson dir, "type" .= J.toJSON rType]
where dirToJson Outgoing = J.String "out"
dirToJson Incoming = J.String "in"
dirToJson Any = J.String "all"
instance J.ToJSON MaybeUniqueness where
toJSON (MaybeUniqueness Nothing) = J.String "none"
toJSON (MaybeUniqueness (Just NodeGlobal)) = J.String "node_global"
toJSON (MaybeUniqueness (Just RelationshipGlobal)) = J.String "relationship_global"
toJSON (MaybeUniqueness (Just NodePathUnique)) = J.String "node_path"
toJSON (MaybeUniqueness (Just RelationshipPath)) = J.String "relationship_path"
instance Default TraversalDesc where
def = TraversalDesc {travOrder = BreadthFirst, travRelFilter = [], travUniqueness = Nothing,
travDepth = Left 1, travNodeFilter = Left ReturnAll}
data TraversalPaging = TraversalPaging {
pageSize :: Integer,
pageLeaseSecs :: Integer
} deriving (Eq, Show)
instance Default TraversalPaging where
def = TraversalPaging {pageSize = 50, pageLeaseSecs = 60}
data ConcreteDirection = In | Out deriving (Eq, Show, Ord)
instance J.FromJSON ConcreteDirection where
parseJSON (J.String "->" ) = return Out
parseJSON (J.String "<-" ) = return In
parseJSON _ = mzero
data Path a b = PathEnd !a | PathLink !a !b !(Path a b) deriving (Eq, Ord, Show)
pathNodes :: Path a b -> [a]
pathNodes (PathEnd n) = [n]
pathNodes (PathLink n _ p) = n : pathNodes p
pathRels :: Path a b -> [b]
pathRels (PathEnd _) = []
pathRels (PathLink _ r p) = r : pathRels p
type IdPath = Path NodePath (RelPath, ConcreteDirection)
instance J.FromJSON IdPath where
parseJSON (J.Object v) = do
nodes <- (map (getNodePath . NodeUrl)) <$> (v .: "nodes")
rels <- (map (getRelPath . RelUrl)) <$> (v .: "relationships")
dirs <- fromMaybe (take (length rels) $ repeat Out) <$> v .:? "directions"
let correctPath = (length nodes) == (length rels + 1) && (length rels == length dirs)
if correctPath
then return $ buildPath nodes rels dirs
else fail $ "Wrong path nodes: " <> show nodes <> " rels: " <> show rels <> " dirs: " <> show dirs
where buildPath [n] [] [] = PathEnd n
buildPath (n:ns) (r:rs) (d:ds) = PathLink n (r, d) (buildPath ns rs ds)
buildPath _ _ _ = undefined
parseJSON _ = fail "wrong type for path"
type FullPath = Path Node Relationship
instance J.FromJSON FullPath where
parseJSON (J.Object v) = do
nodes <- v .: "nodes"
rels <- v .: "relationships"
let correctPath = length nodes == length rels + 1
if correctPath
then return $ buildPath nodes rels
else fail $ "Wrong path nodes: " <> show nodes <> " rels: " <> show rels
where buildPath [n] [] = PathEnd n
buildPath (n:ns) (r:rs) = PathLink n r (buildPath ns rs)
buildPath _ _ = undefined
parseJSON _ = fail "wrong type for path"
data PagedTraversal a = Done | More S.ByteString [a] deriving (Eq, Ord, Show)
bsNodePath :: NodeIdentifier a => a -> S.ByteString
bsNodePath n = TE.encodeUtf8 $ (runNodePath $ getNodePath n)
traversalApi :: NodeIdentifier a => a -> S.ByteString
traversalApi n = bsNodePath n <> "/traverse"
pagedApi :: NodeIdentifier a => a -> S.ByteString
pagedApi n = bsNodePath n <> "/paged/traverse"
proc404 :: NodeIdentifier n => n -> Neo4jException -> a
proc404 n exc@(Neo4jUnexpectedResponseException s)
| s == HT.status404 = throw (Neo4jNoEntityException $ bsNodePath n)
| otherwise = throw exc
proc404 _ exc = throw exc
traverse :: (NodeIdentifier a, J.FromJSON b) => S.ByteString -> TraversalDesc -> a -> Neo4j [b]
traverse path desc start = Neo4j $ \conn ->
httpCreate conn (traversalApi start <> path) (traversalReqBody desc) `catch` proc404 start
traverseGetNodes :: NodeIdentifier a => TraversalDesc -> a -> Neo4j [Node]
traverseGetNodes = traverse "/node"
traverseGetRels :: NodeIdentifier a => TraversalDesc -> a -> Neo4j [Relationship]
traverseGetRels = traverse "/relationship"
traverseGetPath :: NodeIdentifier a => TraversalDesc -> a -> Neo4j [IdPath]
traverseGetPath = traverse "/path"
traverseGetFullPath :: NodeIdentifier a => TraversalDesc -> a -> Neo4j [FullPath]
traverseGetFullPath = traverse "/fullpath"
getPagedValues :: PagedTraversal a -> [a]
getPagedValues Done = []
getPagedValues (More _ r) = r
nextTraversalPage :: J.FromJSON a => PagedTraversal a -> Neo4j (PagedTraversal a)
nextTraversalPage Done = return Done
nextTraversalPage (More pagingUri _) = Neo4j $ \conn -> do
mr <- httpRetrieve conn pagingUri
return $ case mr of
Nothing -> Done
Just r -> More pagingUri r
pagedTraversalDone :: PagedTraversal a -> Bool
pagedTraversalDone Done = True
pagedTraversalDone _ = False
pagingQs :: TraversalPaging -> S.ByteString
pagingQs (TraversalPaging pSize leaseSecs) = "?pageSize=" <> showBs pSize <> "&leaseTime=" <> showBs leaseSecs
where showBs = fromString . show
pagedTraversal :: (NodeIdentifier a, J.FromJSON b) => S.ByteString -> TraversalDesc -> TraversalPaging -> a
-> Neo4j (PagedTraversal b)
pagedTraversal path desc paging start = Neo4j $ \conn -> do
(r, headers) <- httpCreateWithHeaders conn (pagedApi start <> path <> pagingQs paging) (
traversalReqBody desc) `catch` proc404 start
let location = fromMaybe "" $ do
loc <- (S.unpack . snd) <$> find ((==HT.hLocation) . fst) headers
(S.pack . NU.uriPath) <$> NU.parseURI loc
return (More location r)
pagedTraverseGetNodes :: NodeIdentifier a => TraversalDesc -> TraversalPaging -> a -> Neo4j (PagedTraversal Node)
pagedTraverseGetNodes = pagedTraversal "/node"
pagedTraverseGetRels :: NodeIdentifier a => TraversalDesc -> TraversalPaging -> a -> Neo4j(PagedTraversal Relationship)
pagedTraverseGetRels = pagedTraversal "/relationship"
pagedTraverseGetPath :: NodeIdentifier a => TraversalDesc -> TraversalPaging -> a -> Neo4j (PagedTraversal IdPath)
pagedTraverseGetPath = pagedTraversal "/path"
pagedTraverseGetFullPath :: NodeIdentifier a => TraversalDesc -> TraversalPaging -> a -> Neo4j(PagedTraversal FullPath)
pagedTraverseGetFullPath = pagedTraversal "/fullpath"