diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Revision history for net-spider +## 0.3.1.0 -- 2019-07-15 + +* Add `GraphML.Writer` module. + +### Snapshot module + +* Add `SnapshotGraph` type synonym. + +### Timestamp module + +* Add `toTime`, `toSystemTime` and `showTimestamp` functions. + + ## 0.3.0.0 -- 2019-05-03 * Export `Snapshot.Internal` module. This module is only for internal 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.0.0 +version: 0.3.1.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -21,7 +21,9 @@ other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, TypeFamilies, - FlexibleInstances + FlexibleInstances, + DeriveGeneric, + TypeSynonymInstances exposed-modules: NetSpider, NetSpider.Input, NetSpider.Output, @@ -35,7 +37,8 @@ NetSpider.Pair, NetSpider.Query, NetSpider.Log, - NetSpider.Snapshot.Internal + NetSpider.Snapshot.Internal, + NetSpider.GraphML.Writer other-modules: NetSpider.Graph.Internal, NetSpider.Spider.Internal.Graph, NetSpider.Spider.Internal.Log, @@ -55,7 +58,8 @@ containers >=0.5.10.2 && <0.7, data-interval >=1.3.0 && <1.4, extended-reals >=0.2.3.0 && <0.3, - monad-logger >=0.3.28.1 && <0.4 + monad-logger >=0.3.28.1 && <0.4, + scientific >=0.3.6.2 && <0.4 -- executable net-spider -- default-language: Haskell2010 @@ -74,9 +78,10 @@ ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" main-is: Spec.hs -- default-extensions: - -- other-extensions: - -- other-modules: - build-depends: base, net-spider, vector, + other-extensions: OverloadedStrings, + DeriveGeneric + other-modules: NetSpider.GraphML.WriterSpec + build-depends: base, net-spider, vector, text, aeson, hspec >=2.4.4 flag server-test diff --git a/src/NetSpider/GraphML/Writer.hs b/src/NetSpider/GraphML/Writer.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/GraphML/Writer.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-} +-- | +-- Module: NetSpider.GraphML.Writer +-- Description: Serialize a Snapshot graph into GraphML format. +-- Maintainer: Toshio Ito +-- +-- This module defines tools to serialize a 'SnapshotGraph' into +-- [GraphML](http://graphml.graphdrawing.org/primer/graphml-primer.html) +-- format. +-- +-- @since 0.3.1.0 +module NetSpider.GraphML.Writer + ( -- * Functions + writeGraphML, + writeGraphMLWith, + -- * Options + WriteOption, + defWriteOption, + -- ** accessors for WriteOption + woptDefaultDirected, + -- * NodeID + NodeID, + ToNodeID(..), + nodeIDByShow, + -- * Attributes + AttributeKey, + AttributeValue(..), + ToAttributes(..), + valueFromAeson, + attributesFromAeson + ) where + +import qualified Data.Aeson as Aeson +import Data.Foldable (foldl') +import Data.Greskell.Graph + ( PropertyMap, Property(..), allProperties + ) +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 qualified Data.Scientific as Sci +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.Snapshot + ( SnapshotNode, nodeId, nodeTimestamp, isOnBoundary, nodeAttributes, + SnapshotLink, sourceNode, destinationNode, linkTimestamp, isDirected, linkAttributes, + SnapshotGraph + ) +import NetSpider.Timestamp + ( Timestamp(epochTime, timeZone), + showTimestamp + ) + +-- | Node ID in GraphML. +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" + +-- | Key of attribute. +type AttributeKey = Text + +-- | Typed value of attribute. +data AttributeValue = AttrBoolean Bool + | AttrInt Int + | AttrLong Integer + | AttrFloat Float + | AttrDouble Double + | AttrString Text + deriving (Show,Eq,Ord) + +-- | Type that can be converted to list of attributes. +class ToAttributes a where + toAttributes :: a -> [(AttributeKey, AttributeValue)] + +instance ToAttributes () where + toAttributes _ = [] + +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 + toAttributes Nothing = [] + toAttributes (Just a) = toAttributes a + +-- | Make 'AttributeValue' from aeson's 'Aeson.Value'. It returns +-- 'Nothing', if the input is null, an object or an array. If the +-- input is a number, the output uses 'AttrDouble'. +valueFromAeson :: Aeson.Value -> Maybe AttributeValue +valueFromAeson v = + case v of + Aeson.String t -> Just $ AttrString t + Aeson.Bool b -> Just $ AttrBoolean b + Aeson.Number n -> Just $ AttrDouble $ Sci.toRealFloat n + _ -> Nothing + +-- | Make attributes from aeson's 'Aeson.Value'. It assumes the input +-- is an object, and its values can be converted by +-- 'valueFromAeson'. Otherwise, it returns 'Nothing'. +attributesFromAeson :: Aeson.Value -> Maybe [(AttributeKey, AttributeValue)] +attributesFromAeson v = + case v of + Aeson.Object o -> mapM convElem $ HM.toList o + _ -> Nothing + where + convElem (k, val) = fmap ((,) k) $ valueFromAeson val + +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 + +-- | Type specifier of 'AttributeValue' +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" + +-- | Domain (`for` field of the key) of attribute. +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" + +-- | Meta data for a key. +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 + } + +-- | Storage of key metadata. +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 = " 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 + +timestampAttrs :: Timestamp -> [(AttributeKey, AttributeValue)] +timestampAttrs t = + [ ("@timestamp", AttrLong $ toInteger $ epochTime t), + ("@timestamp_str", AttrString $ showTimestamp t) + ] ++ timezone_attrs + where + timezone_attrs = + case timeZone t of + Nothing -> [] + Just tz -> [ ("@tz_offset_min", AttrInt $ timeZoneMinutes tz), + ("@tz_summer_only", AttrBoolean $ timeZoneSummerOnly tz), + ("@tz_name", AttrString $ pack $ timeZoneName tz) + ] + +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 -> timestampAttrs 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 = timestampAttrs $ 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 -> " key_id_str <> "\">" <> val_str <> "\n" + where + key_id_str = showAttributeID index + val_str = showAttributeValue val + +-- | Options to write GraphML. Use 'defWriteOption' to get the default +-- values. +data WriteOption = + WriteOption + { woptDefaultDirected :: Bool + -- ^ If 'True', set GraphML's @edgedefault@ attribute to + -- @directed@. If 'False', set it to @undirected@. Note that + -- regardless of this option, each @edge@ element specifies + -- @directed@ attribute explicitly. + -- + -- Default: 'True' + } + deriving (Show,Eq,Ord) + +defWriteOption :: WriteOption +defWriteOption = + WriteOption + { woptDefaultDirected = True + } + +-- | 'writeGraphMLWith' the default options. +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 = "\n" + graphml_header = " " 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 = "\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 = " edgedefault_str <> "\">\n" + graph_footer = "\n" + nodes = mconcat $ map writeNode input_nodes + edges = mconcat $ map writeLink input_links + showAttribute' (k,v) = (" " <> ) $ showAttribute key_store k v + writeNode n = " (encodeNodeID $ nodeId n) <> "\">\n" + <> (mconcat $ map showAttribute' $ nodeMetaValues n) + <> " \n" + writeLink l = " (encodeNodeID $ sourceNode l) + <> "\" target=\"" <> (encodeNodeID $ destinationNode l) + <> "\" directed=\"" <> showDirected l <> "\">\n" + <> (mconcat $ map showAttribute' $ linkMetaValues l) + <> " \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 diff --git a/src/NetSpider/Snapshot.hs b/src/NetSpider/Snapshot.hs --- a/src/NetSpider/Snapshot.hs +++ b/src/NetSpider/Snapshot.hs @@ -6,7 +6,9 @@ -- A snapshot graph is a graph constructed from the NetSpider -- database. It reprensents a graph at specific time. module NetSpider.Snapshot - ( -- * SnapshotNode + ( -- * SnapshotGraph + SnapshotGraph, + -- * SnapshotNode SnapshotNode, nodeId, isOnBoundary, @@ -24,13 +26,13 @@ ) where import NetSpider.Snapshot.Internal - ( SnapshotNode(..), + ( SnapshotGraph, + SnapshotNode(..), SnapshotLink(..), linkNodeTuple, linkNodePair ) import NetSpider.Timestamp (Timestamp) - nodeId :: SnapshotNode n na -> n nodeId = _nodeId diff --git a/src/NetSpider/Snapshot/Internal.hs b/src/NetSpider/Snapshot/Internal.hs --- a/src/NetSpider/Snapshot/Internal.hs +++ b/src/NetSpider/Snapshot/Internal.hs @@ -10,7 +10,8 @@ -- -- @since 0.3.0.0 module NetSpider.Snapshot.Internal - ( SnapshotLink(..), + ( SnapshotGraph, + SnapshotLink(..), linkNodeTuple, linkNodePair, SnapshotNode(..) @@ -19,6 +20,11 @@ import Data.Bifunctor (Bifunctor(..)) import NetSpider.Pair (Pair(..)) import NetSpider.Timestamp (Timestamp) + +-- | The snapshot graph, which is a collection nodes and links. +-- +-- @since 0.3.1.0 +type SnapshotGraph n na la = ([SnapshotNode n na], [SnapshotLink n la]) -- | A link in the snapshot graph. -- diff --git a/src/NetSpider/Spider.hs b/src/NetSpider/Spider.hs --- a/src/NetSpider/Spider.hs +++ b/src/NetSpider/Spider.hs @@ -58,7 +58,7 @@ Interval ) import NetSpider.Query.Internal (FoundNodePolicy(..)) -import NetSpider.Snapshot.Internal (SnapshotNode(..), SnapshotLink(..)) +import NetSpider.Snapshot.Internal (SnapshotGraph, SnapshotNode(..), SnapshotLink(..)) import NetSpider.Spider.Config (Config(..), defConfig) import NetSpider.Spider.Internal.Graph ( gMakeFoundNode, gAllNodes, gHasNodeID, gHasNodeEID, gNodeEID, gNodeID, gMakeNode, gClearAll, @@ -146,7 +146,7 @@ getSnapshotSimple :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n, LinkAttributes fla, NodeAttributes na) => Spider n na fla -> n -- ^ ID of the node where it starts traversing. - -> IO ([SnapshotNode n na], [SnapshotLink n fla]) + -> IO (SnapshotGraph n na fla) getSnapshotSimple spider start_nid = getSnapshot spider $ defQuery [start_nid] @@ -155,7 +155,7 @@ getSnapshot :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n, LinkAttributes fla, NodeAttributes na) => Spider n na fla -> Query n na fla sla - -> IO ([SnapshotNode n na], [SnapshotLink n sla]) + -> IO (SnapshotGraph n na sla) getSnapshot spider query = do ref_state <- newIORef $ initSnapshotState $ startsFrom query recurseVisitNodesForSnapshot spider query ref_state diff --git a/src/NetSpider/Spider/Internal/Spider.hs b/src/NetSpider/Spider/Internal/Spider.hs --- a/src/NetSpider/Spider/Internal/Spider.hs +++ b/src/NetSpider/Spider/Internal/Spider.hs @@ -30,3 +30,7 @@ spiderClient :: Gr.Client } +-- Implementation note: Type parameters n, na, fla are phantom. They +-- are used to bind the input types (type arguments for FoundNode etc) +-- and the output types (type arguments for SnapshotNode etc) + diff --git a/src/NetSpider/Timestamp.hs b/src/NetSpider/Timestamp.hs --- a/src/NetSpider/Timestamp.hs +++ b/src/NetSpider/Timestamp.hs @@ -12,13 +12,17 @@ now, -- * Manipulation addSec, - -- * Conversion + -- * Convert to Timestamp parseTimestamp, fromS, fromZonedTime, fromUTCTime, fromSystemTime, fromLocalTime, + -- * Convert from Timestamp + toTime, + toSystemTime, + showTimestamp, showEpochTime ) where @@ -26,17 +30,20 @@ import Data.Char (isDigit) import Data.Int (Int64) import Data.List (sortOn) +import Data.Monoid ((<>)) import Data.Text (Text, pack) import Data.Time.Calendar (Day, fromGregorian) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.System (utcToSystemTime, SystemTime(..), systemToUTCTime) +import qualified Data.Time.Format as DTFormat import Data.Time.LocalTime ( TimeZone(..), getZonedTime, ZonedTime(..), zonedTimeToUTC, LocalTime(LocalTime), localTimeToUTC, - TimeOfDay(TimeOfDay) + TimeOfDay(TimeOfDay), utcToLocalTime, utcToZonedTime ) import qualified Data.Time.LocalTime as LocalTime -import Data.Time.Clock (UTCTime) -import Data.Time.Clock.System (utcToSystemTime, SystemTime(..)) import qualified Text.ParserCombinators.ReadP as P import Text.Read (readEither) +import Text.Printf (printf) -- | Timestamp when graph elements are observed. data Timestamp = @@ -59,11 +66,71 @@ fromEpochMillisecond :: Int64 -> Timestamp fromEpochMillisecond msec = Timestamp msec Nothing +-- | Show 'Timestamp' with a basic ISO 8601 format. +-- +-- >>> showTimestamp $ fromS "2019-10-20T12:45:00" +-- "2019-10-20T12:45:00.000" +-- >>> showTimestamp $ fromS "1999-03-21T10:11Z" +-- "1999-03-21T10:11:00.000Z" +-- >>> showTimestamp $ fromS "2016-11-30T22:03:00.034+09:00" +-- "2016-11-30T22:03:00.034+09:00" +-- >>> showTimestamp $ fromS "2000-04-07T09:31-05:00" +-- "2000-04-07T09:31:00.000-05:00" +-- +-- @since 0.3.1.0 +showTimestamp :: Timestamp -> Text +showTimestamp = pack . either simpleFormat formatZT . toTime + where + dtFormat :: DTFormat.FormatTime t => String -> t -> String + dtFormat = DTFormat.formatTime DTFormat.defaultTimeLocale + simpleFormat :: DTFormat.FormatTime t => t -> String + simpleFormat = dtFormat "%Y-%m-%dT%H:%M:%S.%03q" + formatZT zt = simpleFormat zt <> formatZone (zonedTimeZone zt) + formatZone z = if timeZoneName z == "" + then formatOffset $ timeZoneMinutes z + else if z == LocalTime.utc + then "Z" + else dtFormat "%Z" z + formatOffset o = sign <> hour <> ":" <> minute + where + sign = if o < 0 then "-" else "+" + abo = abs o + hour = printf "%02d" (abo `div` 60) + minute = printf "%02d" (abo `mod` 60) + -- | Show 'epochTime' of 'Timestamp' as 'Text'. -- -- @since 0.2.0.0 showEpochTime :: Timestamp -> Text showEpochTime = pack . show . epochTime + +-- | Convert to 'LocalTime' (if the 'Timestamp' has no time zone) or +-- 'ZonedTime' (otherwise). If it makes the 'LocalTime' as if the time +-- zone was UTC. +-- +-- @since 0.3.1.0 +toTime :: Timestamp -> Either LocalTime ZonedTime +toTime ts = maybe (Left localtime) (Right . toZT) $ timeZone ts + where + utctime = systemToUTCTime $ toSystemTime ts + localtime = utcToLocalTime LocalTime.utc utctime + toZT tz = utcToZonedTime tz utctime + +-- | Convert 'Timestamp' to 'SystemTime'. It discards 'timeZone' +-- field. +-- +-- >>> toSystemTime $ fromEpochMillisecond 1043221 +-- MkSystemTime {systemSeconds = 1043, systemNanoseconds = 221000000} +-- >>> toSystemTime $ fromEpochMillisecond (-192332) +-- MkSystemTime {systemSeconds = -193, systemNanoseconds = 668000000} +-- +-- @since 0.3.1.0 +toSystemTime :: Timestamp -> SystemTime +toSystemTime ts = MkSystemTime sec nsec + where + epoch_time = epochTime ts + sec = epoch_time `div` 1000 + nsec = fromIntegral (epoch_time `mod` 1000) * 1000000 -- | Get the current system time. -- diff --git a/test/NetSpider/GraphML/WriterSpec.hs b/test/NetSpider/GraphML/WriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/NetSpider/GraphML/WriterSpec.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} +module NetSpider.GraphML.WriterSpec (main,spec) where + +import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions) +import Data.List (sortOn) +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +-- import qualified Data.Text.Lazy.IO as TLIO +import GHC.Generics (Generic) +import NetSpider.Snapshot.Internal + ( SnapshotNode(..), SnapshotLink(..) + ) +import NetSpider.Timestamp (fromEpochMillisecond, fromS) +import Test.Hspec + +import NetSpider.GraphML.Writer + ( writeGraphML, + ToAttributes(..), + AttributeValue(..), + attributesFromAeson, + writeGraphMLWith, + defWriteOption, + woptDefaultDirected + ) + +main :: IO () +main = hspec spec + +data Att1 = + Att1 + { at1Hoge :: Int, + at1Foo :: Text, + at1Buzz :: Bool + } + deriving (Show,Eq,Ord) + +instance ToAttributes Att1 where + toAttributes a = [ ("hoge", AttrInt $ at1Hoge a), + ("foo", AttrString $ at1Foo a), + ("buzz", AttrBoolean $ at1Buzz a) + ] + +data Att2 = + Att2 + { at2_quux :: Double, + at2_huga :: Text + } + deriving (Show,Eq,Ord,Generic) + +instance ToJSON Att2 where + toEncoding = genericToEncoding defaultOptions + +instance ToAttributes Att2 where + toAttributes a = sortOn fst $ fromJust $ attributesFromAeson $ toJSON a + +spec :: Spec +spec = do + describe "writeGraphML" $ do + specify "no attribute, directed and undirected mixed, node id escaped" $ do + let time_with_tz = fromS "2018-09-23T08:48:52+09:00" + nodes :: [SnapshotNode Text ()] + nodes = [ SnapshotNode + { _nodeId = "\"the root\"", + _isOnBoundary = False, + _nodeTimestamp = Just $ fromEpochMillisecond 100, + _nodeAttributes = Just () + }, + SnapshotNode + { _nodeId = "☃", + _isOnBoundary = True, + _nodeTimestamp = Nothing, + _nodeAttributes = Nothing + }, + SnapshotNode + { _nodeId = "", + _isOnBoundary = False, + _nodeTimestamp = Just $ time_with_tz, + _nodeAttributes = Just () + } + ] + links :: [SnapshotLink Text ()] + links = [ SnapshotLink + { _sourceNode = "\"the root\"", + _destinationNode = "☃", + _isDirected = True, + _linkTimestamp = fromEpochMillisecond 100, + _linkAttributes = () + }, + SnapshotLink + { _sourceNode = "", + _destinationNode = "\"the root\"", + _isDirected = False, + _linkTimestamp = time_with_tz, + _linkAttributes = () + } + ] + expected = mconcat $ map (<> "\n") + [ "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + " ", + " 100", + " 1970-01-01T00:00:00.100", + " false", + " ", + " ", + " true", + " ", + " ", + " 1537660132000", + " 2018-09-23T08:48:52.000+09:00", + " 540", + " false", + " ", + " false", + " ", + " ", + " 100", + " 1970-01-01T00:00:00.100", + " ", + " ", + " 1537660132000", + " 2018-09-23T08:48:52.000+09:00", + " 540", + " false", + " ", + " ", + "", + "" + ] + got = writeGraphML (nodes, links) + -- TLIO.putStrLn got + got `shouldBe` expected + specify "with attributes" $ do + let nodes :: [SnapshotNode Int Att1] + nodes = [ SnapshotNode + { _nodeId = 100, + _isOnBoundary = False, + _nodeTimestamp = Just $ fromEpochMillisecond 155, + _nodeAttributes = Just $ Att1 + { at1Hoge = 99, + at1Foo = "new\nline", + at1Buzz = False + } + }, + SnapshotNode + { _nodeId = 200, + _isOnBoundary = False, + _nodeTimestamp = Nothing, + _nodeAttributes = Just $ Att1 + { at1Hoge = 2099, + at1Foo = "", + at1Buzz = True + } + } + ] + links :: [SnapshotLink Int Att2] + links = [ SnapshotLink + { _sourceNode = 100, + _destinationNode = 200, + _isDirected = True, + _linkTimestamp = fromEpochMillisecond 155, + _linkAttributes = Att2 + { at2_quux = 109.25, + at2_huga = "HUGA" + } + + } + ] + expected = mconcat $ map (<> "\n") + [ "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + " ", + " 155", + " 1970-01-01T00:00:00.155", + " false", + " 99", + " new line", + " false", + " ", + " ", + " false", + " 2099", + " ", + " true", + " ", + " ", + " 155", + " 1970-01-01T00:00:00.155", + " HUGA", + " 109.25", + " ", + "", + "" + ] + got = writeGraphML (nodes, links) + -- TLIO.putStrLn got + got `shouldBe` expected + describe "writeGraphMLWith" $ do + specify "woptDefaultDirected = False" $ do + let nodes :: [SnapshotNode Text ()] + nodes = [ SnapshotNode + { _nodeId = "n1", + _isOnBoundary = False, + _nodeTimestamp = Just $ fromEpochMillisecond 200, + _nodeAttributes = Just () + }, + SnapshotNode + { _nodeId = "n2", + _isOnBoundary = False, + _nodeTimestamp = Nothing, + _nodeAttributes = Nothing + } + ] + links :: [SnapshotLink Text ()] + links = [ SnapshotLink + { _sourceNode = "n1", + _destinationNode = "n2", + _isDirected = True, + _linkTimestamp = fromEpochMillisecond 200, + _linkAttributes = () + } + ] + expected = mconcat $ map (<> "\n") + [ "", + "", + "", + "", + "", + "", + "", + "", + " ", + " 200", + " 1970-01-01T00:00:00.200", + " false", + " ", + " ", + " false", + " ", + " ", + " 200", + " 1970-01-01T00:00:00.200", + " ", + "", + "" + ] + opt = defWriteOption + { woptDefaultDirected = False + } + got = writeGraphMLWith opt (nodes, links) + got `shouldBe` expected