{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, OverloadedStrings,
FlexibleInstances, UndecidableInstances, NoMonomorphismRestriction, FlexibleContexts #-}
module NetSpider.Graph.Internal
(
EID,
VNode,
VFoundNode,
VFoundNodeData(..),
NodeAttributes(..),
keyTimestamp,
gSetTimestamp,
gVFoundNodeData,
EFinds,
EFindsData(..),
LinkAttributes(..),
gSetLinkState,
gFindsTarget,
gEFindsData,
makeFoundNode,
makeFoundLink
) where
import Control.Category ((<<<))
import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
import Data.Foldable (Foldable)
import Data.Greskell
( 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 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, linkStateToText, linkStateFromText,
FoundLink(..), FoundNode(..)
)
type EID = ElementID
newtype VNode = VNode AVertex
deriving (Show,Eq,ElementData,Element,Vertex,FromGraphSON)
type TsEpoch = Int64
keyTimestamp :: Key VFoundNode TsEpoch
keyTimestamp = "@timestamp"
keyTzOffset :: Key (AVertexProperty TsEpoch) Int
keyTzOffset = "@tz_offset_min"
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
]
newtype VFoundNode = VFoundNode AVertex
deriving (Show,Eq,ElementData,Element,Vertex,FromGraphSON)
data VFoundNodeData na =
VFoundNodeData
{ vfnId :: EID VFoundNode,
vfnTimestamp :: Timestamp,
vfnAttributes :: na
}
deriving (Show)
labelVProps :: AsLabel (PMap Multi GValue)
labelVProps = "props"
labelVFoundNodeID :: AsLabel (ElementID VFoundNode)
labelVFoundNodeID = "vid"
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
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
newtype EFinds = EFinds AEdge
deriving (Show,Eq,ElementData,Element,Edge,FromGraphSON)
data EFindsData la =
EFindsData
{ efId :: EID EFinds,
efTargetId :: EID VNode,
efLinkState :: LinkState,
efLinkAttributes :: la
}
deriving (Show)
keyLinkState :: Key EFinds Text
keyLinkState = "@link_state"
gSetLinkState :: LinkState -> Binder (Walk SideEffect EFinds EFinds)
gSetLinkState ls = do
var_ls <- newBind $ linkStateToText $ ls
return $ gProperty keyLinkState var_ls
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
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 NodeAttributes ps where
writeNodeAttributes :: ps -> Binder (Walk SideEffect VFoundNode VFoundNode)
parseNodeAttributes :: PMap Multi GValue -> Parser ps
instance NodeAttributes () where
writeNodeAttributes _ = return gIdentity
parseNodeAttributes _ = return ()
instance (FromGraphSON v, ToJSON v, Foldable c, Traversable c, NonEmptyLike c) => NodeAttributes (PMap c v) where
writeNodeAttributes = writePMapProperties
parseNodeAttributes = traverse parseGraphSON . pMapFromList . pMapToList
class LinkAttributes ps where
writeLinkAttributes :: ps -> Binder (Walk SideEffect EFinds EFinds)
parseLinkAttributes :: PMap Single GValue -> Parser ps
instance LinkAttributes () where
writeLinkAttributes _ = return gIdentity
parseLinkAttributes _ = return ()
instance (FromGraphSON v, ToJSON v, Foldable c, Traversable c, NonEmptyLike c) => LinkAttributes (PMap c v) where
writeLinkAttributes = writePMapProperties
parseLinkAttributes = traverse parseGraphSON . pMapFromList . pMapToList
makeFoundLink :: n
-> EFindsData la
-> FoundLink n la
makeFoundLink target_nid ef_data =
FoundLink
{ targetNode = target_nid,
linkState = efLinkState ef_data,
linkAttributes = efLinkAttributes ef_data
}
makeFoundNode :: n
-> VFoundNodeData na
-> [FoundLink n la]
-> FoundNode n na la
makeFoundNode subject_nid vfn neighbors =
FoundNode
{ subjectNode = subject_nid,
foundAt = vfnTimestamp vfn,
neighborLinks = neighbors,
nodeAttributes = vfnAttributes vfn
}