{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-}
module NetSpider.GraphML.Writer
(
writeGraphML,
writeGraphMLWith,
WriteOption,
defWriteOption,
woptDefaultDirected,
NodeID,
ToNodeID(..),
nodeIDByShow,
AttributeKey,
AttributeValue(..),
ToAttributes(..),
valueFromAeson,
attributesFromAeson
) where
import Data.Foldable (foldl')
import Data.Greskell.Graph (Property(..))
import Data.Hashable (Hashable(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>), Monoid(..), mconcat)
import Data.Semigroup (Semigroup(..))
import Data.Text (Text, pack, unpack)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Data.Time (TimeZone(..))
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Generics (Generic)
import NetSpider.GraphML.Attribute
( AttributeKey,
AttributeValue(..),
ToAttributes(..),
valueFromAeson,
attributesFromAeson
)
import NetSpider.Snapshot
( SnapshotNode, nodeId, nodeTimestamp, isOnBoundary, nodeAttributes,
SnapshotLink, sourceNode, destinationNode, linkTimestamp, isDirected, linkAttributes,
SnapshotGraph
)
import NetSpider.Timestamp
( Timestamp(epochTime, timeZone),
showTimestamp
)
type NodeID = Text
class ToNodeID a where
toNodeID :: a -> NodeID
nodeIDByShow :: Show a => a -> NodeID
nodeIDByShow = pack . show
instance ToNodeID Text where
toNodeID = id
instance ToNodeID TL.Text where
toNodeID = TL.toStrict
instance ToNodeID String where
toNodeID = pack
instance ToNodeID Int where
toNodeID = nodeIDByShow
instance ToNodeID Int8 where
toNodeID = nodeIDByShow
instance ToNodeID Int16 where
toNodeID = nodeIDByShow
instance ToNodeID Int32 where
toNodeID = nodeIDByShow
instance ToNodeID Int64 where
toNodeID = nodeIDByShow
instance ToNodeID Word where
toNodeID = nodeIDByShow
instance ToNodeID Word8 where
toNodeID = nodeIDByShow
instance ToNodeID Word16 where
toNodeID = nodeIDByShow
instance ToNodeID Word32 where
toNodeID = nodeIDByShow
instance ToNodeID Integer where
toNodeID = nodeIDByShow
instance ToNodeID Float where
toNodeID = nodeIDByShow
instance ToNodeID Double where
toNodeID = nodeIDByShow
instance ToNodeID Bool where
toNodeID True = "true"
toNodeID False = "false"
sbuild :: Show a => a -> TLB.Builder
sbuild = TLB.fromString . show
showAttributeValue :: AttributeValue -> TLB.Builder
showAttributeValue v =
case v of
AttrBoolean False -> "false"
AttrBoolean True -> "true"
AttrInt i -> sbuild i
AttrLong i -> sbuild i
AttrFloat f -> sbuild f
AttrDouble d -> sbuild d
AttrString t -> encodeXML t
data AttributeType = ATBoolean
| ATInt
| ATLong
| ATFloat
| ATDouble
| ATString
deriving (Show,Eq,Ord,Generic)
instance Hashable AttributeType
valueType :: AttributeValue -> AttributeType
valueType v =
case v of
AttrBoolean _ -> ATBoolean
AttrInt _ -> ATInt
AttrLong _ -> ATLong
AttrFloat _ -> ATFloat
AttrDouble _ -> ATDouble
AttrString _ -> ATString
showAttributeType :: AttributeType -> TLB.Builder
showAttributeType t =
case t of
ATBoolean -> "boolean"
ATInt -> "int"
ATLong -> "long"
ATFloat -> "float"
ATDouble -> "double"
ATString -> "string"
data AttributeDomain = DomainGraph
| DomainNode
| DomainEdge
| DomainAll
deriving (Show,Eq,Ord,Generic)
instance Hashable AttributeDomain
showDomain :: AttributeDomain -> TLB.Builder
showDomain d =
case d of
DomainGraph -> "graph"
DomainNode -> "node"
DomainEdge -> "edge"
DomainAll -> "all"
data KeyMeta =
KeyMeta
{ kmName :: AttributeKey,
kmType :: AttributeType,
kmDomain :: AttributeDomain
}
deriving (Show,Eq,Ord,Generic)
instance Hashable KeyMeta
makeMetaValue :: AttributeDomain -> AttributeKey -> AttributeValue -> (KeyMeta, AttributeValue)
makeMetaValue d k v = (meta, v)
where
meta = KeyMeta { kmName = k,
kmType = valueType v,
kmDomain = d
}
data KeyStore =
KeyStore
{ ksMetas :: [KeyMeta],
ksIndexFor :: HashMap KeyMeta Int
}
deriving (Show,Eq,Ord)
emptyKeyStore :: KeyStore
emptyKeyStore = KeyStore { ksMetas = [],
ksIndexFor = HM.empty
}
addKey :: KeyMeta -> KeyStore -> KeyStore
addKey new_meta ks = KeyStore { ksMetas = if HM.member new_meta $ ksIndexFor ks
then ksMetas ks
else new_meta : ksMetas ks,
ksIndexFor = HM.insertWith (\_ old -> old) new_meta (length $ ksMetas ks) $ ksIndexFor ks
}
keyIndex :: KeyStore -> KeyMeta -> Maybe Int
keyIndex ks km = HM.lookup km $ ksIndexFor ks
showAllKeys :: TLB.Builder -> KeyStore -> TLB.Builder
showAllKeys prefix ks = mconcat $ map (prefix <>) $ catMaybes $ map (showKeyMeta ks) $ reverse $ ksMetas ks
showKeyMeta :: KeyStore -> KeyMeta -> Maybe TLB.Builder
showKeyMeta ks km = fmap (\i -> showKeyMetaWithIndex i km) $ keyIndex ks km
showAttributeID :: Int -> TLB.Builder
showAttributeID index = "d" <> sbuild index
showKeyMetaWithIndex :: Int -> KeyMeta -> TLB.Builder
showKeyMetaWithIndex index km = "<key id=\"" <> id_str <> "\" for=\"" <> domain_str
<> "\" attr.name=\"" <> name_str <> "\" attr.type=\"" <> type_str <> "\"/>\n"
where
id_str = showAttributeID index
domain_str = showDomain $ kmDomain km
name_str = encodeXML $ kmName km
type_str = showAttributeType $ kmType km
nodeMetaKeys :: ToAttributes na => SnapshotNode n na -> [KeyMeta]
nodeMetaKeys n = map fst $ nodeMetaValues n
nodeMetaValues :: ToAttributes na => SnapshotNode n na -> [(KeyMeta, AttributeValue)]
nodeMetaValues n = map convert $ base <> attrs
where
timestamp = case nodeTimestamp n of
Nothing -> []
Just t -> toAttributes t
base = timestamp <> [("@is_on_boundary", AttrBoolean $ isOnBoundary n)]
attrs = toAttributes $ nodeAttributes n
convert (k, v) = makeMetaValue DomainNode k v
linkMetaKeys :: ToAttributes la => SnapshotLink n la -> [KeyMeta]
linkMetaKeys l = map fst $ linkMetaValues l
linkMetaValues :: ToAttributes la => SnapshotLink n la -> [(KeyMeta, AttributeValue)]
linkMetaValues l = map convert $ base <> attrs
where
base = toAttributes $ linkTimestamp l
attrs = toAttributes $ linkAttributes l
convert (k, v) = makeMetaValue DomainEdge k v
showAttribute :: KeyStore -> KeyMeta -> AttributeValue -> TLB.Builder
showAttribute ks km val =
case keyIndex ks km of
Nothing -> ""
Just index -> "<data key=\"" <> key_id_str <> "\">" <> val_str <> "</data>\n"
where
key_id_str = showAttributeID index
val_str = showAttributeValue val
data WriteOption =
WriteOption
{ woptDefaultDirected :: Bool
}
deriving (Show,Eq,Ord)
defWriteOption :: WriteOption
defWriteOption =
WriteOption
{ woptDefaultDirected = True
}
writeGraphML :: (ToNodeID n, ToAttributes na, ToAttributes la)
=> SnapshotGraph n na la
-> TL.Text
writeGraphML = writeGraphMLWith defWriteOption
writeGraphMLWith :: (ToNodeID n, ToAttributes na, ToAttributes la)
=> WriteOption
-> SnapshotGraph n na la
-> TL.Text
writeGraphMLWith wopt (input_nodes, input_links) =
TLB.toLazyText ( xml_header
<> graphml_header
<> keys
<> graph_header
<> nodes
<> edges
<> graph_footer
<> graphml_footer
)
where
xml_header = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
graphml_header = "<graphml xmlns=\"http://graphml.graphdrawing.org/xmlns\"\n"
<> " xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"\n"
<> " xsi:schemaLocation=\"http://graphml.graphdrawing.org/xmlns http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd\">\n"
graphml_footer = "</graphml>\n"
keys = showAllKeys "" key_store
key_metas = concat $ map nodeMetaKeys input_nodes <> map linkMetaKeys input_links
key_store = foldl' (\acc m -> addKey m acc) emptyKeyStore key_metas
edgedefault_str = if woptDefaultDirected wopt
then "directed"
else "undirected"
graph_header = "<graph edgedefault=\"" <> edgedefault_str <> "\">\n"
graph_footer = "</graph>\n"
nodes = mconcat $ map writeNode input_nodes
edges = mconcat $ map writeLink input_links
showAttribute' (k,v) = (" " <> ) $ showAttribute key_store k v
writeNode n = " <node id=\"" <> (encodeNodeID $ nodeId n) <> "\">\n"
<> (mconcat $ map showAttribute' $ nodeMetaValues n)
<> " </node>\n"
writeLink l = " <edge source=\"" <> (encodeNodeID $ sourceNode l)
<> "\" target=\"" <> (encodeNodeID $ destinationNode l)
<> "\" directed=\"" <> showDirected l <> "\">\n"
<> (mconcat $ map showAttribute' $ linkMetaValues l)
<> " </edge>\n"
showDirected l = if isDirected l
then "true"
else "false"
encodeNodeID :: ToNodeID n => n -> TLB.Builder
encodeNodeID = encodeXML . toNodeID
encodeXML :: Text -> TLB.Builder
encodeXML = mconcat . map escape . unpack
where
escape c =
case c of
'<' -> "<"
'>' -> ">"
'&' -> "&"
'"' -> """
'\'' -> "'"
'\n' -> "
"
'\r' -> "
"
_ -> TLB.singleton c