{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, OverloadedStrings, FlexibleInstances #-}
module NetSpider.Graph.Internal
(
EID,
VNode,
VFoundNode(..),
NodeAttributes(..),
EFinds(..),
LinkAttributes(..)
) where
import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
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
)
import qualified Data.Greskell as Greskell
import Data.Greskell.Extra (writeAllProperties)
import Data.Text (Text, unpack)
import Data.Time.LocalTime (TimeZone(..))
import NetSpider.Timestamp (Timestamp(..))
import NetSpider.Found (LinkState)
newtype EID = EID (Either Int Text)
deriving (Show,Eq,Ord,FromGraphSON)
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
data VNode
instance Element VNode where
type ElementID VNode = EID
type ElementProperty VNode = AVertexProperty
instance Vertex VNode
data VFoundNode na =
VFoundNode
{ vfnId :: EID,
vfnTimestamp :: Timestamp,
vfnAttributes :: na
}
deriving (Show)
instance Element (VFoundNode na) where
type ElementID (VFoundNode na) = EID
type ElementProperty (VFoundNode na) = AVertexProperty
instance Vertex (VFoundNode na)
instance NodeAttributes na => FromGraphSON (VFoundNode na) where
parseGraphSON gv = fromAVertex =<< 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
data EFinds la =
EFinds
{ efId :: EID,
efTargetId :: EID,
efLinkState :: LinkState,
efLinkAttributes :: la
}
deriving (Show)
instance Element (EFinds la) where
type ElementID (EFinds la) = EID
type ElementProperty (EFinds la) = AProperty
instance Edge (EFinds la) where
type EdgeVertexID (EFinds la) = EID
instance LinkAttributes la => FromGraphSON (EFinds la) where
parseGraphSON gv = fromAEdge =<< parseGraphSON gv
where
fromAEdge ae = EFinds
<$> (parseGraphSON $ aeId ae)
<*> (parseGraphSON $ aeInV ae)
<*> (parseOneValue "@link_state" ps)
<*> (parseLinkAttributes ps)
where
ps = aeProperties ae
class NodeAttributes ps where
writeNodeAttributes :: ps -> Binder (Walk SideEffect (VFoundNode ps) (VFoundNode ps))
parseNodeAttributes :: PropertyMapList AVertexProperty GValue -> Parser ps
instance NodeAttributes () where
writeNodeAttributes _ = return gIdentity
parseNodeAttributes _ = return ()
instance (FromGraphSON v, ToJSON v) => NodeAttributes (PropertyMapList AVertexProperty v) where
writeNodeAttributes = writeAllProperties
parseNodeAttributes = traverse parseGraphSON
class LinkAttributes ps where
writeLinkAttributes :: ps -> Binder (Walk SideEffect (EFinds ps) (EFinds ps))
parseLinkAttributes :: PropertyMapSingle AProperty GValue -> Parser ps
instance LinkAttributes () where
writeLinkAttributes _ = return gIdentity
parseLinkAttributes _ = return ()
instance (FromGraphSON v, ToJSON v) => LinkAttributes (PropertyMapSingle AProperty v) where
writeLinkAttributes = writeAllProperties
parseLinkAttributes = traverse parseGraphSON