diff --git a/dataflow.cabal b/dataflow.cabal --- a/dataflow.cabal +++ b/dataflow.cabal @@ -1,5 +1,5 @@ name: dataflow -version: 0.5.3.0 +version: 0.5.4.0 synopsis: Generate Graphviz documents from a Haskell representation. description: Outputs .dot files that can be processed by the dot command. Currently it only supports the DFD output format diff --git a/examples/legend.svg b/examples/legend.svg --- a/examples/legend.svg +++ b/examples/legend.svg @@ -4,49 +4,52 @@ - - + + Untitled - + cluster_trust - -TrustBoundary + +TrustBoundary function - -Function + +Function database -Database - - +Database + + function->database - - -Flow + + +(3) +Flow io - -InputOutput + +InputOutput function->io - - -Flow + + +(1) +Flow function->io - - -Flow -(backwards) + + +(2) +Flow +(backwards) diff --git a/examples/webapp.svg b/examples/webapp.svg --- a/examples/webapp.svg +++ b/examples/webapp.svg @@ -4,68 +4,72 @@ - + Webapp - -Webapp + +Webapp cluster_browser - -Browser + +Browser cluster_aws - -Amazon AWS + +Amazon AWS client - -Client + +Client server - -Web Server + +Web Server client->server - - -Request / + + +(1) +Request / client->server - - -Response -User Profile + + +(3) +Response +User Profile analytics - -Google -Analytics + +Google +Analytics client->analytics - - -Log -Page Navigation + + +(4) +Log +Page Navigation logs -Logs - - +Logs + + server->logs - - -Log -User IP + + +(2) +Log +User IP diff --git a/src/DataFlow/DFD.hs b/src/DataFlow/DFD.hs --- a/src/DataFlow/DFD.hs +++ b/src/DataFlow/DFD.hs @@ -1,10 +1,24 @@ module DataFlow.DFD where import Text.Printf +import Control.Monad +import Control.Monad.State import qualified DataFlow.Core as C import DataFlow.Graphviz import DataFlow.Graphviz.EdgeNormalization +type Step = Int +type DFD v = State Step v + +incrStep :: DFD () +incrStep = modify (+ 1) + +-- | Get the next \"step\" number (the order of flow arrows in the diagram). +nextStep :: DFD Int +nextStep = do + incrStep + get + inQuotes :: String -> String inQuotes s = "\"" ++ s ++ "\"" @@ -25,21 +39,25 @@ small :: String -> String small "" = "" -small s = "" ++ s ++ "" +small s = printf "%s" s -convertObject :: C.Object -> StmtList +color :: String -> String -> String +color _ "" = "" +color c s = printf "%s" c s -convertObject (C.InputOutput id' name) = [ +convertObject :: C.Object -> DFD StmtList + +convertObject (C.InputOutput id' name) = return [ NodeStmt (ID id') [ Attr (ID "shape") (ID "square"), Attr (ID "style") (ID "bold"), - label $ bold name + label $ printf "
%s
" (bold name) ] ] -convertObject (C.TrustBoundary id' name objects) = - let sgId = (ID $ "cluster_" ++ id') - objectStmts = convertObjects objects +convertObject (C.TrustBoundary id' name objects) = do + objectStmts <- convertObjects objects + let sgId = ID $ "cluster_" ++ id' sgAttrStmt = AttrStmt Graph [ Attr (ID "fontsize") (ID "10"), Attr (ID "fontcolor") (ID "grey35"), @@ -48,35 +66,35 @@ label $ italic name ] stmts = sgAttrStmt : objectStmts - in [SubgraphStmt $ Subgraph sgId stmts] + return [SubgraphStmt $ Subgraph sgId stmts] -convertObject (C.Function id' name) = - [ +convertObject (C.Function id' name) = return [ NodeStmt (ID id') [ Attr (ID "shape") (ID "circle"), label $ bold name ] ] -convertObject (C.Database id' name) = - [ +convertObject (C.Database id' name) = return [ NodeStmt (ID id') [ Attr (ID "shape") (ID "none"), label $ printf "
%s
" (bold name) ] ] -convertObject (C.Flow i1 i2 op desc) = - [ - EdgeStmt (EdgeExpr (IDOperand (NodeID (ID i1) Nothing)) - Arrow - (IDOperand (NodeID (ID i2) Nothing))) [ - label $ bold op ++ "
" ++ small desc - ] - ] +convertObject (C.Flow i1 i2 op desc) = do + step <- nextStep + let stepStr = color "#3184e4" $ bold $ printf "(%d) " step + return [ + EdgeStmt (EdgeExpr (IDOperand (NodeID (ID i1) Nothing)) + Arrow + (IDOperand (NodeID (ID i2) Nothing))) [ + label $ stepStr ++ bold op ++ "
" ++ small desc + ] + ] -convertObjects :: [C.Object] -> StmtList -convertObjects = concatMap convertObject +convertObjects :: [C.Object] -> DFD StmtList +convertObjects = liftM concat . mapM convertObject defaultGraphStmts :: StmtList defaultGraphStmts = [ @@ -99,11 +117,18 @@ EqualsStmt (ID "rankdir") (ID "t") ] +convertDiagram :: C.Diagram -> DFD Graph + +convertDiagram (C.Diagram (Just name) objects) = do + let lbl = EqualsStmt (ID "label") (ID $ inAngleBrackets $ bold name) + objs <- convertObjects objects + let stmts = lbl : defaultGraphStmts ++ objs + return $ normalize $ Digraph (ID $ inQuotes name) stmts + +convertDiagram (C.Diagram Nothing objects) = do + objs <- convertObjects objects + return $ normalize $ Digraph (ID "Untitled") $ defaultGraphStmts ++ objs + asDFD :: C.Diagram -> Graph -asDFD (C.Diagram (Just name) objects) = - normalize $ Digraph (ID $ inQuotes name) $ - let lbl = EqualsStmt (ID "label") (ID $ inAngleBrackets $ bold name) - in lbl : defaultGraphStmts ++ convertObjects objects -asDFD (C.Diagram Nothing objects) = - normalize $ Digraph (ID "Untitled") $ - defaultGraphStmts ++ convertObjects objects +asDFD d = evalState (convertDiagram d) 0 +