diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ # Revision history for net-spider +## 0.4.0.0 -- 2019-12-28 + +* Use `greskell-1.0.0.0`. + +### Graph module + +* [BREAKING CHANGE] Change signatures of `parseNodeAttributes` and + `parseLinkAttributes` functions, because now `PropertMapList` and + `PropertyMapSingle` are deprecated. +* [BREAKING CHANGE] Remove `ToAttributes` instance from types of + `PropertyMap` class, because `PropertyMap` is now deprecated. +* [BREAKING CHANGE] Now `EID` is alias for `ElementID`. It's kind is + now `* -> *`. This fixes #5. +* [BREAKING CHANGE] Kind of `VFoundNode` and `EFinds` is now `*` (was + `* -> *`). +* [BREAKING CHANGE] Remove `NodeAttributes PropertyMapList` instance + and `LinkAttributes PropertyMapSingle` instance, because + PropertyMaps are deprecated. +* Add `NodeAttributes` and `LinkAttributes` instances to `PMap`. + + ## 0.3.3.0 -- 2019-10-13 ### Interval module diff --git a/net-spider.cabal b/net-spider.cabal --- a/net-spider.cabal +++ b/net-spider.cabal @@ -1,5 +1,5 @@ name: net-spider -version: 0.3.3.0 +version: 0.4.0.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -23,7 +23,10 @@ TypeFamilies, FlexibleInstances, DeriveGeneric, - TypeSynonymInstances + TypeSynonymInstances, + UndecidableInstances, + NoMonomorphismRestriction, + FlexibleContexts exposed-modules: NetSpider, NetSpider.Input, NetSpider.Output, @@ -50,7 +53,7 @@ time >=1.8.0.2 && <1.10, vector >=0.12.0.1 && <0.13, greskell-websocket >=0.1.1 && <0.2, - greskell >=0.2.3 && <0.3, + greskell >=1.0.0 && <1.1, aeson >=1.2.4 && <1.5, safe-exceptions >=0.1.6 && <0.2, text >=1.2.2.2 && <1.3, diff --git a/src/NetSpider/Graph/Internal.hs b/src/NetSpider/Graph/Internal.hs --- a/src/NetSpider/Graph/Internal.hs +++ b/src/NetSpider/Graph/Internal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, OverloadedStrings, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, OverloadedStrings, + FlexibleInstances, UndecidableInstances, NoMonomorphismRestriction, FlexibleContexts #-} -- | -- Module: NetSpider.Graph.Internal -- Description: @@ -11,134 +12,220 @@ -- * VNode VNode, -- * VFoundNode - VFoundNode(..), + VFoundNode, + VFoundNodeData(..), NodeAttributes(..), + keyTimestamp, + gSetTimestamp, + gVFoundNodeData, -- * EFinds - EFinds(..), - LinkAttributes(..) + EFinds, + EFindsData(..), + LinkAttributes(..), + gSetLinkState, + gFindsTarget, + gEFindsData ) where +import Control.Category ((<<<)) import Data.Aeson (ToJSON(..), FromJSON(..), Value(..)) +import Data.Foldable (Foldable) import Data.Greskell - ( FromGraphSON(..), parseOneValue, lookupOne, lookupOneValue, - Element(..), Vertex, Edge(..), - AVertexProperty(..), AVertex(..), AProperty, AEdge(..), - Walk, SideEffect, - Binder, Parser, PropertyMapList, PropertyMapSingle, GValue, - gIdentity, gProperty, - newBind, allProperties, propertyKey, propertyValue + ( FromGraphSON(..), + ElementData(..), Element(..), Vertex, Edge, + ElementID, + AVertexProperty, AVertex, AEdge, + Walk, SideEffect, Transform, unsafeCastEnd, + Binder, Parser, GValue, + gIdentity, gProperty, gPropertyV, (=:), gProperties, gInV, + newBind, + Key, AsLabel, unKey, + PMap, Multi, Single, lookupAs, PMapLookupException, + pMapFromList, pMapToList, pMapToFail, + gProject, gValueMap, gByL, gId, Keys(..) ) -import qualified Data.Greskell as Greskell -import Data.Greskell.Extra (writeAllProperties) -import Data.Text (Text, unpack) +import Data.Greskell.NonEmptyLike (NonEmptyLike) +import Data.Greskell.Extra (writePMapProperties) +import Data.Int (Int64) +import Data.Text (Text, unpack, pack) import Data.Time.LocalTime (TimeZone(..)) import NetSpider.Timestamp (Timestamp(..)) -import NetSpider.Found (LinkState) +import NetSpider.Found (LinkState, linkStateToText, linkStateFromText) -- | Generic element ID used in the graph DB. -newtype EID = EID (Either Int Text) - deriving (Show,Eq,Ord,FromGraphSON) +type EID = ElementID -instance ToJSON EID where - toJSON (EID e) = either toJSON toJSON e -instance FromJSON EID where - parseJSON (String s) = return $ EID $ Right s - parseJSON v = fmap (EID . Left) $ parseJSON v +-- | The \"node\" vertex. +newtype VNode = VNode AVertex + deriving (Show,Eq,ElementData,Element,Vertex,FromGraphSON) +type TsEpoch = Int64 --- | The \"node\" vertex. -data VNode +keyTimestamp :: Key VFoundNode TsEpoch +keyTimestamp = "@timestamp" -instance Element VNode where - type ElementID VNode = EID - type ElementProperty VNode = AVertexProperty +keyTzOffset :: Key (AVertexProperty TsEpoch) Int +keyTzOffset = "@tz_offset_min" -instance Vertex VNode +keyTzSummerOnly :: Key (AVertexProperty TsEpoch) Bool +keyTzSummerOnly = "@tz_summer_only" +keyTzName :: Key (AVertexProperty TsEpoch) Text +keyTzName = "@tz_name" + +gSetTimestamp :: Timestamp -> Binder (Walk SideEffect VFoundNode VFoundNode) +gSetTimestamp ts = do + var_epoch <- newBind $ epochTime ts + meta_props <- makeMetaProps $ timeZone ts + return $ gPropertyV Nothing keyTimestamp var_epoch meta_props + where + makeMetaProps Nothing = return [] + makeMetaProps (Just tz) = do + offset <- newBind $ timeZoneMinutes tz + summer <- newBind $ timeZoneSummerOnly tz + name <- newBind $ pack $ timeZoneName tz + return $ [ keyTzOffset =: offset, + keyTzSummerOnly =: summer, + keyTzName =: name + ] + -- | The \"found_node\" vertex. -data VFoundNode na = - VFoundNode - { vfnId :: EID, +newtype VFoundNode = VFoundNode AVertex + deriving (Show,Eq,ElementData,Element,Vertex,FromGraphSON) + +-- | Properties of the \"found_node\" vertex. +data VFoundNodeData na = + VFoundNodeData + { vfnId :: EID VFoundNode, vfnTimestamp :: Timestamp, vfnAttributes :: na } deriving (Show) -instance Element (VFoundNode na) where - type ElementID (VFoundNode na) = EID - type ElementProperty (VFoundNode na) = AVertexProperty +labelVProps :: AsLabel (PMap Multi GValue) +labelVProps = "props" -instance Vertex (VFoundNode na) +labelVFoundNodeID :: AsLabel (ElementID VFoundNode) +labelVFoundNodeID = "vid" -instance NodeAttributes na => FromGraphSON (VFoundNode na) where - parseGraphSON gv = fromAVertex =<< parseGraphSON gv +labelMetaProps :: AsLabel (PMap Single GValue) +labelMetaProps = "mprops" + +gVFoundNodeData :: Walk Transform VFoundNode (VFoundNodeData na) +gVFoundNodeData = unsafeCastEnd $ gProject + ( gByL labelVFoundNodeID gId) + [ gByL labelVProps $ gValueMap KeysNil, + gByL labelMetaProps (gValueMap KeysNil <<< gProperties [keyTimestamp]) + ] + +instance NodeAttributes na => FromGraphSON (VFoundNodeData na) where + parseGraphSON gv = fromPMap =<< parseGraphSON gv where - fromAVertex av = do - eid <- parseGraphSON $ avId av - ts_prop <- case lookupOne "@timestamp" $ avProperties av of - Nothing -> fail ("Cannot find property named @timestamp") - Just p -> return p - epoch_ts <- parseGraphSON $ avpValue ts_prop - mtz <- parseTimeZone ts_prop - attrs <- parseNodeAttributes $ avProperties av - return $ VFoundNode { vfnId = eid, - vfnTimestamp = Timestamp { epochTime = epoch_ts, - timeZone = mtz - }, - vfnAttributes = attrs - } - parseTimeZone ts_prop = - case (get "@tz_offset_min", get "@tz_summer_only", get "@tz_name") of - (Left _, Left _, Left _) -> return Nothing - (eo, es, en) -> do - offset <- parseE eo - is_summer_only <- parseE es - name <- parseE en - return $ Just $ TimeZone { timeZoneMinutes = offset, - timeZoneSummerOnly = is_summer_only, - timeZoneName = unpack name - } - where - get k = maybe (Left ("Cannot find property " ++ unpack k)) Right $ lookupOneValue k $ avpProperties ts_prop - parseE :: (FromGraphSON a) => Either String GValue -> Parser a - parseE = either fail parseGraphSON + lookupAsF k pm = pMapToFail $ lookupAs k pm + fromPMap :: NodeAttributes na => PMap Single GValue -> Parser (VFoundNodeData na) + fromPMap pm = do + eid <- lookupAsF labelVFoundNodeID pm + props <- lookupAsF labelVProps pm + mprops <- lookupAsF labelMetaProps pm + attrs <- parseNodeAttributes props + epoch_ts <- lookupAsF keyTimestamp props + mtz <- parseTimeZone mprops + return $ + VFoundNodeData + { vfnId = eid, + vfnTimestamp = Timestamp { epochTime = epoch_ts, + timeZone = mtz + }, + vfnAttributes = attrs + } + parseTimeZone ts_prop = do + case (get keyTzOffset, get keyTzSummerOnly, get keyTzName) of + (Left _, Left _, Left _) -> return Nothing + (eo, es, en) -> do + offset <- eToP eo + is_summer_only <- eToP es + name <- eToP en + return $ Just $ TimeZone { timeZoneMinutes = offset, + timeZoneSummerOnly = is_summer_only, + timeZoneName = unpack name + } + where + get :: FromGraphSON b => Key a b -> Either PMapLookupException b + get k = lookupAs k ts_prop + eToP = either (fail . show) return -- | \"finds\" edge. -data EFinds la = - EFinds - { efId :: EID, - efTargetId :: EID, +newtype EFinds = EFinds AEdge + deriving (Show,Eq,ElementData,Element,Edge,FromGraphSON) + +-- | Properties of \"finds\" edge. +data EFindsData la = + EFindsData + { efId :: EID EFinds, + efTargetId :: EID VNode, efLinkState :: LinkState, efLinkAttributes :: la } deriving (Show) -instance Element (EFinds la) where - type ElementID (EFinds la) = EID - type ElementProperty (EFinds la) = AProperty +keyLinkState :: Key EFinds Text +keyLinkState = "@link_state" -instance Edge (EFinds la) where - type EdgeVertexID (EFinds la) = EID +gSetLinkState :: LinkState -> Binder (Walk SideEffect EFinds EFinds) +gSetLinkState ls = do + var_ls <- newBind $ linkStateToText $ ls + return $ gProperty keyLinkState var_ls -instance LinkAttributes la => FromGraphSON (EFinds la) where - parseGraphSON gv = fromAEdge =<< parseGraphSON gv +gFindsTarget :: Walk Transform EFinds VNode +gFindsTarget = gInV + +labelEProps :: AsLabel (PMap Single GValue) +labelEProps = "eprops" + +labelEFindsID :: AsLabel (ElementID EFinds) +labelEFindsID = "eid" + +labelEFindsTarget :: AsLabel (ElementID VNode) +labelEFindsTarget = "vnode" + +gEFindsData :: Walk Transform EFinds (EFindsData la) +gEFindsData = unsafeCastEnd $ gProject + ( gByL labelEProps $ gValueMap KeysNil ) + [ gByL labelEFindsID $ gId, + gByL labelEFindsTarget (gId <<< gFindsTarget) + ] + +instance LinkAttributes la => FromGraphSON (EFindsData la) where + parseGraphSON gv = fromPMap =<< parseGraphSON gv where - fromAEdge ae = EFinds - <$> (parseGraphSON $ aeId ae) - <*> (parseGraphSON $ aeInV ae) - <*> (parseOneValue "@link_state" ps) - <*> (parseLinkAttributes ps) - where - ps = aeProperties ae + lookupAsF k pm = pMapToFail $ lookupAs k pm + fromPMap :: LinkAttributes la => PMap Single GValue -> Parser (EFindsData la) + fromPMap pm = do + props <- lookupAsF labelEProps pm + eid <- lookupAsF labelEFindsID pm + target <- lookupAsF labelEFindsTarget pm + ls <- parseLinkState =<< lookupAsF keyLinkState props + attrs <- parseLinkAttributes props + return $ + EFindsData + { efId = eid, + efTargetId = target, + efLinkState = ls, + efLinkAttributes = attrs + } + parseLinkState t = + case linkStateFromText t of + Nothing -> fail ("Failed to parse " ++ (unpack $ unKey $ keyLinkState) ++ " field.") + Just a -> return a -- | Class of user-defined types for node attributes. Its content is -- stored in the NetSpider database. class NodeAttributes ps where - writeNodeAttributes :: ps -> Binder (Walk SideEffect (VFoundNode ps) (VFoundNode ps)) + writeNodeAttributes :: ps -> Binder (Walk SideEffect VFoundNode VFoundNode) -- ^ Return 'Walk' to write the attributes to the 'VFoundNode'. - parseNodeAttributes :: PropertyMapList AVertexProperty GValue -> Parser ps + parseNodeAttributes :: PMap Multi GValue -> Parser ps -- ^ Parse the vertex proprerties into the attributes. -- | No attributes. @@ -146,20 +233,19 @@ writeNodeAttributes _ = return gIdentity parseNodeAttributes _ = return () --- | Straightforward implementation. Note that 'writeNodeAttributes' --- does not write meta-properties of the 'AVertexProperty'. +-- | Straightforward implementation. -- --- @since 0.3.0.0 -instance (FromGraphSON v, ToJSON v) => NodeAttributes (PropertyMapList AVertexProperty v) where - writeNodeAttributes = writeAllProperties - parseNodeAttributes = traverse parseGraphSON +-- @since 0.4.0.0 +instance (FromGraphSON v, ToJSON v, Foldable c, Traversable c, NonEmptyLike c) => NodeAttributes (PMap c v) where + writeNodeAttributes = writePMapProperties + parseNodeAttributes = traverse parseGraphSON . pMapFromList . pMapToList -- | Class of user-defined types for link attributes. Its content is -- stored in the NetSpider database. class LinkAttributes ps where - writeLinkAttributes :: ps -> Binder (Walk SideEffect (EFinds ps) (EFinds ps)) + writeLinkAttributes :: ps -> Binder (Walk SideEffect EFinds EFinds) -- ^ Return 'Walk' to write the attributes to the 'EFinds'. - parseLinkAttributes :: PropertyMapSingle AProperty GValue -> Parser ps + parseLinkAttributes :: PMap Single GValue -> Parser ps -- ^ Parse the edge proprerties into the attributes. -- | No attributes. @@ -167,10 +253,10 @@ writeLinkAttributes _ = return gIdentity parseLinkAttributes _ = return () --- | Straightforward implementation +-- | Straightforward implementation. -- --- @since 0.3.0.0 -instance (FromGraphSON v, ToJSON v) => LinkAttributes (PropertyMapSingle AProperty v) where - writeLinkAttributes = writeAllProperties - parseLinkAttributes = traverse parseGraphSON +-- @since 0.4.0.0 +instance (FromGraphSON v, ToJSON v, Foldable c, Traversable c, NonEmptyLike c) => LinkAttributes (PMap c v) where + writeLinkAttributes = writePMapProperties + parseLinkAttributes = traverse parseGraphSON . pMapFromList . pMapToList diff --git a/src/NetSpider/GraphML/Writer.hs b/src/NetSpider/GraphML/Writer.hs --- a/src/NetSpider/GraphML/Writer.hs +++ b/src/NetSpider/GraphML/Writer.hs @@ -32,9 +32,7 @@ import qualified Data.Aeson as Aeson import Data.Foldable (foldl') -import Data.Greskell.Graph - ( PropertyMap, Property(..), allProperties - ) +import Data.Greskell.Graph (Property(..)) import Data.Hashable (Hashable(..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM @@ -141,11 +139,6 @@ instance ToAttributes [(AttributeKey, AttributeValue)] where toAttributes = id - -instance (PropertyMap m, Property p) => ToAttributes (m p AttributeValue) where - toAttributes = toAttributes . map toPair . allProperties - where - toPair p = (propertyKey p, propertyValue p) -- | 'Nothing' is mapped to empty attributes. instance ToAttributes a => ToAttributes (Maybe a) where diff --git a/src/NetSpider/Spider.hs b/src/NetSpider/Spider.hs --- a/src/NetSpider/Spider.hs +++ b/src/NetSpider/Spider.hs @@ -22,6 +22,7 @@ clearAll ) where +import Control.Category ((<<<)) import Control.Exception.Safe (throwString, bracket) import Control.Monad (void, mapM_, mapM) import Data.Aeson (ToJSON) @@ -30,8 +31,9 @@ import Data.Greskell ( runBinder, ($.), (<$.>), (<*.>), Binder, ToGreskell(GreskellReturn), AsIterator(IteratorItem), FromGraphSON, - liftWalk, gLimit, gIdentity, gSelectN, gAs, - lookupAsM, newAsLabel + liftWalk, gLimit, gIdentity, gSelect1, gAs, gProject, gByL, gIdentity, + lookupAsM, newAsLabel, + Transform, Walk ) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -49,7 +51,11 @@ import qualified Network.Greskell.WebSocket as Gr import NetSpider.Graph (EID, LinkAttributes, NodeAttributes) -import NetSpider.Graph.Internal (VFoundNode(..), EFinds(..)) +import NetSpider.Graph.Internal + ( VFoundNode, EFinds, VNode, + VFoundNodeData(..), EFindsData(..), + gVFoundNodeData, gEFindsData + ) import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) import NetSpider.Log (runWriterLoggingM, WriterLoggingM, logDebugW, LogLine, spack) import NetSpider.Pair (Pair) @@ -129,12 +135,12 @@ vToMaybe :: Vector a -> Maybe a vToMaybe v = v V.!? 0 -getNode :: (ToJSON n) => Spider n na fla -> n -> IO (Maybe EID) +getNode :: (ToJSON n) => Spider n na fla -> n -> IO (Maybe (EID VNode)) getNode spider nid = fmap vToMaybe $ Gr.slurpResults =<< submitB spider gt where gt = gNodeEID <$.> gHasNodeID spider nid <*.> pure gAllNodes -getOrMakeNode :: (ToJSON n) => Spider n na fla -> n -> IO EID +getOrMakeNode :: (ToJSON n) => Spider n na fla -> n -> IO (EID VNode) getOrMakeNode spider nid = do mvid <- getNode spider nid case mvid of @@ -193,8 +199,8 @@ traverseEFindsOneHop :: (FromGraphSON n, NodeAttributes na, LinkAttributes fla) => Spider n na fla -> Interval Timestamp - -> EID - -> IO (Maybe (VFoundNode na), [(VFoundNode na, EFinds fla, n)]) + -> EID VNode + -> IO (Maybe (VFoundNodeData na), [(VFoundNodeData na, EFindsData fla, n)]) traverseEFindsOneHop spider time_interval visit_eid = (,) <$> getLatestVFoundNode <*> getTraversedEdges where foundNodeTraversal = fmap gSelectFoundNode (gFilterFoundNodeByTime time_interval) @@ -203,25 +209,30 @@ getLatestVFoundNode = fmap vToMaybe $ Gr.slurpResults =<< submitQuery where submitQuery = submitB spider binder - binder = gLatestFoundNode <$.> foundNodeTraversal + binder = gVFoundNodeData <$.> gLatestFoundNode <$.> foundNodeTraversal getTraversedEdges = fmap V.toList $ traverse extractFromSMap =<< Gr.slurpResults =<< submitQuery where submitQuery = Gr.submit (spiderClient spider) query (Just bindings) ((query, label_vfn, label_ef, label_target_nid), bindings) = runBinder $ do lvfn <- newAsLabel + lvfnd <- newAsLabel lef <- newAsLabel + lefd <- newAsLabel ln <- newAsLabel - gt <- gSelectN lvfn lef [ln] - <$.> gAs ln <$.> gNodeID spider <$.> gFindsTarget + gt <- gProject + ( gByL lvfnd (gVFoundNodeData <<< gSelect1 lvfn) ) + [ gByL lefd (gEFindsData <<< gSelect1 lef), + gByL ln (gIdentity :: Walk Transform n n) + ] <$.> gNodeID spider <$.> gFindsTarget <$.> gAs lef <$.> gFinds <$.> gAs lvfn <$.> foundNodeTraversal - return (gt, lvfn, lef, ln) + return (gt, lvfnd, lefd, ln) extractFromSMap smap = (,,) <$> lookupAsM label_vfn smap <*> lookupAsM label_ef smap <*> lookupAsM label_target_nid smap -makeLinkSample :: n -> VFoundNode na -> EFinds la -> n -> LinkSample n la +makeLinkSample :: n -> VFoundNodeData na -> EFindsData la -> n -> LinkSample n la makeLinkSample subject_nid vfn efinds target_nid = LinkSample { lsSubjectNode = subject_nid, lsTargetNode = target_nid, @@ -291,7 +302,7 @@ data SnapshotState n na fla = SnapshotState { ssUnvisitedNodes :: Queue n, - ssVisitedNodes :: HashMap n (Maybe (VFoundNode na)), + ssVisitedNodes :: HashMap n (Maybe (VFoundNodeData na)), -- ^ If the visited node has no observation yet, its node -- attributes 'Nothing'. ssVisitedLinks :: HashMap (LinkSampleID n) [LinkSample n fla] @@ -321,7 +332,7 @@ initSnapshotState :: (Ord n, Hashable n) => [n] -> SnapshotState n na fla initSnapshotState init_unvisited_nodes = emptySnapshotState { ssUnvisitedNodes = newQueue init_unvisited_nodes } -addVisitedNode :: (Eq n, Hashable n) => n -> Maybe (VFoundNode na) -> SnapshotState n na fla -> SnapshotState n na fla +addVisitedNode :: (Eq n, Hashable n) => n -> Maybe (VFoundNodeData na) -> SnapshotState n na fla -> SnapshotState n na fla addVisitedNode nid mv state = state { ssVisitedNodes = HM.insert nid mv $ ssVisitedNodes state } isAlreadyVisited :: (Eq n, Hashable n) => SnapshotState n na fla -> n -> Bool diff --git a/src/NetSpider/Spider/Internal/Graph.hs b/src/NetSpider/Spider/Internal/Graph.hs --- a/src/NetSpider/Spider/Internal/Graph.hs +++ b/src/NetSpider/Spider/Internal/Graph.hs @@ -52,6 +52,10 @@ ( EID, VNode, VFoundNode, EFinds, LinkAttributes(..), NodeAttributes(..) ) +import NetSpider.Graph.Internal + ( keyTimestamp, gSetTimestamp, gSetLinkState, + gFindsTarget + ) import NetSpider.Found (FoundLink(..), LinkState(..), FoundNode(..), linkStateToText) import NetSpider.Query (Interval, Extended(..)) import NetSpider.Timestamp (Timestamp(..)) @@ -61,7 +65,7 @@ spiderNodeIdKey :: Spider n na fla -> Key VNode n spiderNodeIdKey = nodeIdKey . spiderConfig -gNodeEID :: Walk Transform VNode EID +gNodeEID :: Walk Transform VNode (EID VNode) gNodeEID = gId gNodeID :: Spider n na fla -> Walk Transform VNode n @@ -75,7 +79,7 @@ var_nid <- newBind nid return $ gHas2 (spiderNodeIdKey spider) var_nid -gHasNodeEID :: (WalkType c) => EID -> Binder (Walk c VNode VNode) +gHasNodeEID :: (WalkType c) => EID VNode -> Binder (Walk c VNode VNode) gHasNodeEID eid = do var_eid <- newBind eid return $ gHasId var_eid @@ -85,25 +89,25 @@ var_nid <- newBind nid return $ gProperty (spiderNodeIdKey spider) var_nid $. sAddV "node" $ source "g" -gGetNodeByEID :: EID -> Binder (Walk Transform s VNode) +gGetNodeByEID :: EID VNode -> Binder (Walk Transform s VNode) gGetNodeByEID vid = do f <- gHasNodeEID vid return (f <<< gV []) -gAllFoundNode :: GTraversal Transform () (VFoundNode na) +gAllFoundNode :: GTraversal Transform () VFoundNode gAllFoundNode = gHasLabel "found_node" $. sV [] $ source "g" -gHasFoundNodeEID :: WalkType c => EID -> Binder (Walk c (VFoundNode na) (VFoundNode na)) +gHasFoundNodeEID :: WalkType c => EID VFoundNode -> Binder (Walk c VFoundNode VFoundNode) gHasFoundNodeEID eid = do var_eid <- newBind eid return $ gHasId var_eid gMakeFoundNode :: (LinkAttributes la, NodeAttributes na) - => EID -- ^ subject node EID - -> [(FoundLink n la, EID)] -- ^ (link, target node EID) + => EID VNode -- ^ subject node EID + -> [(FoundLink n la, EID VNode)] -- ^ (link, target node EID) -> FoundNode n na la - -> Binder (GTraversal SideEffect () (VFoundNode na)) + -> Binder (GTraversal SideEffect () VFoundNode) gMakeFoundNode subject_vid link_pairs fnode = mAddFindsEdges <*.> writeNodeAttributes (nodeAttributes fnode) @@ -111,53 +115,34 @@ <*.> mAddObservedEdge <*.> pure $ sAddV "found_node" $ source "g" where - mAddObservedEdge :: Binder (Walk SideEffect (VFoundNode na) (VFoundNode na)) + mAddObservedEdge :: Binder (Walk SideEffect VFoundNode VFoundNode) mAddObservedEdge = do v <- gGetNodeByEID subject_vid return $ gSideEffect $ emitsAEdge $ gAddE "is_observed_as" $ gFrom v mAddFindsEdges = fmap fold $ traverse mAddFindsEdgeFor link_pairs - mAddFindsEdgeFor :: LinkAttributes la => (FoundLink n la, EID) -> Binder (Walk SideEffect (VFoundNode na) (VFoundNode na)) + mAddFindsEdgeFor :: LinkAttributes la => (FoundLink n la, EID VNode) -> Binder (Walk SideEffect VFoundNode VFoundNode) mAddFindsEdgeFor (link, target_vid) = do v <- gGetNodeByEID target_vid - var_ls <- newBind $ linkStateToText $ linkState link + g_set_link_state <- gSetLinkState $ linkState link addAttrs <- writeLinkAttributes $ linkAttributes link return $ gSideEffect ( addAttrs - <<< gProperty "@link_state" var_ls + <<< g_set_link_state <<< gAddE "finds" (gTo v) ) -keyTimestamp :: Key (VFoundNode na) Int64 -keyTimestamp = "@timestamp" - -gSetTimestamp :: Timestamp -> Binder (Walk SideEffect (VFoundNode na) (VFoundNode na)) -gSetTimestamp ts = do - var_epoch <- newBind $ epochTime ts - meta_props <- makeMetaProps $ timeZone ts - return $ gPropertyV Nothing keyTimestamp var_epoch meta_props - where - makeMetaProps Nothing = return [] - makeMetaProps (Just tz) = do - offset <- newBind $ timeZoneMinutes tz - summer <- newBind $ timeZoneSummerOnly tz - name <- newBind $ pack $ timeZoneName tz - return $ [ "@tz_offset_min" =: offset, - "@tz_summer_only" =: summer, - "@tz_name" =: name - ] - emitsAEdge :: ToGTraversal g => g c s AEdge -> g c s AEdge emitsAEdge = id gClearAll :: GTraversal SideEffect () () gClearAll = void $ gDrop $. liftWalk $ sV' [] $ source "g" -gSelectFoundNode :: Walk Filter (VFoundNode na) (VFoundNode na) -> Walk Transform VNode (VFoundNode na) +gSelectFoundNode :: Walk Filter VFoundNode VFoundNode -> Walk Transform VNode VFoundNode gSelectFoundNode filterFoundNode = liftWalk filterFoundNode <<< gOut ["is_observed_as"] -gLatestFoundNode :: Walk Transform (VFoundNode na) (VFoundNode na) +gLatestFoundNode :: Walk Transform VFoundNode VFoundNode gLatestFoundNode = gLimit 1 <<< gOrder [gBy2 keyTimestamp oDecr] -gFilterFoundNodeByTime :: Interval Timestamp -> Binder (Walk Filter (VFoundNode na) (VFoundNode na)) +gFilterFoundNodeByTime :: Interval Timestamp -> Binder (Walk Filter VFoundNode VFoundNode) gFilterFoundNodeByTime interval = do fl <- filterLower fh <- filterUpper @@ -174,8 +159,5 @@ (Finite ts, False) -> fmap (gHas2P keyTimestamp) $ fmap pLt $ newBind $ epochTime ts (Finite ts, True) -> fmap (gHas2P keyTimestamp) $ fmap pLte $ newBind $ epochTime ts -gFinds :: Walk Transform (VFoundNode na) (EFinds la) +gFinds :: Walk Transform VFoundNode EFinds gFinds = gOutE ["finds"] - -gFindsTarget :: Walk Transform (EFinds la) VNode -gFindsTarget = gInV diff --git a/test/ServerTest/Common.hs b/test/ServerTest/Common.hs --- a/test/ServerTest/Common.hs +++ b/test/ServerTest/Common.hs @@ -14,7 +14,8 @@ import Control.Applicative ((<$>)) import Control.Category ((<<<)) import Control.Exception.Safe (bracket, withException) -import Data.Greskell (parseOneValue, gProperty, newBind) +import Data.Aeson.Types (Parser) +import Data.Greskell (gProperty, newBind, lookupAs, pMapToFail, Key) import Data.List (sort) import Data.Text (Text) import Data.Vector (Vector) @@ -65,24 +66,30 @@ newtype AText = AText Text deriving (Show,Eq,Ord) +keyText :: Key e Text +keyText = "text" + instance NodeAttributes AText where - writeNodeAttributes (AText t) = gProperty "text" <$> newBind t - parseNodeAttributes ps = AText <$> parseOneValue "text" ps + writeNodeAttributes (AText t) = gProperty keyText <$> newBind t + parseNodeAttributes ps = fmap AText $ pMapToFail $ lookupAs keyText ps instance LinkAttributes AText where - writeLinkAttributes (AText t) = gProperty "text" <$> newBind t - parseLinkAttributes ps = AText <$> parseOneValue "text" ps + writeLinkAttributes (AText t) = gProperty keyText <$> newBind t + parseLinkAttributes ps = fmap AText $ pMapToFail $ lookupAs keyText ps newtype AInt = AInt Int deriving (Show,Eq,Ord) +keyInt :: Key e Int +keyInt = "integer" + instance NodeAttributes AInt where - writeNodeAttributes (AInt n) = gProperty "integer" <$> newBind n - parseNodeAttributes ps = AInt <$> parseOneValue "integer" ps + writeNodeAttributes (AInt n) = gProperty keyInt <$> newBind n + parseNodeAttributes ps = fmap AInt $ pMapToFail $ lookupAs keyInt ps instance LinkAttributes AInt where - writeLinkAttributes (AInt n) = gProperty "integer" <$> newBind n - parseLinkAttributes ps = AInt <$> parseOneValue "integer" ps + writeLinkAttributes (AInt n) = gProperty keyInt <$> newBind n + parseLinkAttributes ps = fmap AInt $ pMapToFail $ lookupAs keyInt ps -- | Pair of ports. @@ -96,14 +103,20 @@ } deriving (Show,Eq,Ord) +keySubjectPort :: Key e Text +keySubjectPort = "subject_port" + +keyTargetPort :: Key e Text +keyTargetPort = "target_port" + instance LinkAttributes APorts where writeLinkAttributes ap = do - writeSource <- gProperty "subject_port" <$> newBind (apFst ap) - writeDest <- gProperty "target_port" <$> newBind (apSnd ap) + writeSource <- gProperty keySubjectPort <$> newBind (apFst ap) + writeDest <- gProperty keyTargetPort <$> newBind (apSnd ap) return (writeDest <<< writeSource) parseLinkAttributes ps = APorts - <$> parseOneValue "subject_port" ps - <*> parseOneValue "target_port" ps + <$> (pMapToFail $ lookupAs keySubjectPort ps) + <*> (pMapToFail $ lookupAs keyTargetPort ps) swapAPorts :: APorts -> APorts swapAPorts ap = ap { apFst = apSnd ap,