diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,45 +8,295 @@ ## Usage -So you want to you use DataFlow? Then please read [Usage](USAGE.md). +The following forms are supported by DataFlow. -## Setup +#### IDs -```bash -cabal sandbox init # optional -cabal install --only-dependencies --enable-tests -cabal configure --enable-tests +An ID can contain letters, numbers and underscores. It must start with a +letter. + + +```dot +my_id_contain_4_words ``` -## Build +#### Strings +String literals are written using double quotes. + +```dot +"this is a string and it can contain everything but double quotes and newlines" +``` + +**NOTE!** Escaping characters inside strings is not supported at the moment. + +#### Text Blocks + +Text blocks are special strings, enclosed in backticks, that are can span +multiple lines in the source document. The space characters before the first +non-space characters on each line are trimmed, regardless of the indentation. + +```dot +`this is + a + textblock` +``` + +... would render as: + +``` +this is +a +textblock +``` + +#### Attributes + +Attributes are key-value pairs for diagrams and nodes that are used by +output renderers. Attributes are enclosed by curly brackets. For nodes that +can contain other nodes, attributes must appear before nodes. + +Keys have the same rules as IDs. Values can be strings or text blocks. + +```dot +{ + key1 = "attr value" + key2 = `attr + value` +} +``` + +#### `diagram` + +`diagram` is the top-level form and must appear exactly once in a DataFlow +document. It can contain attributes and nodes. + +```dot +diagram { + title = "My diagram" +} +``` + +#### `boundary` + +The `boundary` form declares a TrustBoundary node that can contain +attributes and other nodes. Boundaries are only allowed in the top-level +diagram. + +```dot +diagram { + boundary { + title = "My System" + } +} +``` + +#### nodes: `io`, `function`, `database` + +The `io`, `function` and `database` forms declare `InputOutput`, `Function` and +`Database` nodes, respectively. The nodes have IDs and they can contain +attributes. Empty attribute brackets can be omitted. + +```dot +diagram { + io thing1 + + io thing2 { + title = "Thing 2" + } +} + +``` + +#### `->` + +The `->` form declares a `Flow` between the nodes referenced by their +IDs. It can contain attributes. Empty attribute brackets can be omitted. +Flows must be declared after all nodes. + +Note that the arrow can be reversed as well (`<-`). + +```dot +diagram { + thing1 -> thing2 + + thing1 <- thing2 { + operation = "Greet" + data = "A nice greeting" + } +} +``` + +## Example + +The image from the top of this README is rendered from the following DataFlow +document. + +```dot +diagram { + title = "Webapp" + + threats = ` + No particular threats at this point. + + It's **extremely** safe.` + + boundary { + title = "Browser" + + function client { + title = "Client" + } + } + + boundary { + title = "Amazon AWS" + + function server { + title = "Web Server" + } + database logs { + title = "Logs" + } + } + io analytics { + title = "Google Analytics" + } + + client -> server { + operation = "Request /" + description = `User navigates with a browser to see some content.` + } + server -> logs { + operation = "Log" + data = `The user + IP address.` + description = `Logged to a ELK stack.` + } + server -> client { + operation = "Response" + data = "User Profile" + description = `The server responds with some HTML.` + } + analytics <- client { + operation = "Log" + data = "Page Navigation" + description = `The Google Analytics plugin sends navigation + data to Google.` + } +} +``` + +## Run DataFlow + +The `dataflow` executable takes an output format and a DataFlow source document +and writes the output to `stdout`. + ```bash -cabal build +dataflow (dfd|seq) FILE ``` -## Install +## DFD -If you initialized a sandbox the executable will end up in the sandbox, i.e. -`.cabal-sandbox/bin/dataflow`. If you have no sandbox it will end up in -`~/.cabal/bin/dataflow`. If you get any stange errors during install try a `cabal clean` +![DFD Legend](examples/legend.dfd.png) +To use the *DFD* output you need [Graphviz](http://www.graphviz.org/) installed. + ```bash -cabal install +dataflow dfd webapp.flow | dot -Tpng > webapp.png ``` +### Output -## Tests +![DFD Output](examples/webapp.dfd.png) +## Sequence Diagram + +![Sequence Diagram Legend](examples/legend.seq.png) + +You can use [PlantUML](http://plantuml.sourceforge.net/) to generate a sequence +diagram. + ```bash -./run-tests.sh -# or... -./watch-tests.sh +dataflow seq webapp.flow | java -Djava.awt.headless=true -jar plantuml.jar -tpng -pipe > webapp.png ``` -## Building the Examples +### Output +![Sequence Diagram Output](examples/webapp.seq.png) + +## Templating + +You can use [Hastache](https://github.com/lymar/hastache) to output arbitrary +text with its Mustache-like templates. + ```bash -make -C examples +dataflow template template.ha webapp.flow > webapp.html ``` + +### Built-in Functions and Values + +* `markdown` - Convert the attribute at the given key from Markdown to HTML. + + ```mustache + {{#markdown}}my_markdown_attr{{/markdown}} + ``` + +* `html_linebreaks` - Replace `\n` with `
` elements in the attribute at + the given key, to retain linebreaks in HTML output. + + ```mustache + {{#html_linebreaks}}my_formatted_attr{{/html_linebreaks}} + ``` + +* `filename_without_extension` - The input `.flow` file name with no path and + no extension. Useful when generating graphics and text/HTML with matching + filenames (e.g. `my-flow.html` includes `my-flow.png`). + + ```mustache + + ``` + +* `flows` - a list of all the Flow nodes in the diagram. Attributes of the + flow is accessible inside the iteration scope. + + ```mustache +
    + {{#flows}} +
  1. {{description}}
    2. + {{/flows}} +
+ ``` + +For an example see [template.ha](examples/template.ha) and the output HTML in +[webapp.html](examples/webapp.html). + +### Output + +![Sequence Diagram Output](examples/webapp.seq.png) + +## Makefile Example + +The following Makefile finds `.flow` sources in `src` and generates DFDs, in +SVG format, in `dist`. + +```make +SOURCES=$(shell find src/*.flow) +TARGETS=$(SOURCES:src/%.flow=dist/%.dfd.svg) + +K := $(if $(shell which dataflow),,$(error "No dataflow executable in PATH. See https://github.com/SonyMobile/dataflow for install instructions)))")) + +dist/%.dfd.svg: src/%.flow + @dataflow dfd $< | dot -Tsvg > $@ + +dfd: $(TARGETS) + +clean: + rm -f $(TARGETS) +``` + +## Build Instructions + +See [BUILD.md](BUILD.md). ## License diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -1,36 +1,79 @@ module Main where +import System.IO import System.Environment -import DataFlow.Reader -import DataFlow.DFD -import DataFlow.SequenceDiagram -import DataFlow.Graphviz.Renderer -import DataFlow.PlantUML.Renderer +import System.Exit +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.Text.Lazy.IO as TL -data Command = DFD | Lint +import DataFlow.Reader +import qualified DataFlow.DFD as DFD +import qualified DataFlow.SequenceDiagram as SEQ +import qualified DataFlow.Graphviz.Renderer as GVR +import qualified DataFlow.PlantUML.Renderer as PUR +import qualified DataFlow.Hastache.Renderer as HR +import qualified DataFlow.JSONGraphFormat.Renderer as JG -usage :: String -usage = "Usage: dataflow (dfd|seq) FILE" +usage :: IO () +usage = hPutStrLn stderr $ unlines [ + "Usage: dataflow command args*", + "", + "Commands", + "--------", + "dfd SRC - outputs a DFD in the Graphviz DOT format", + "seq SRC - outputs a sequence diagram in PlantUML format", + "template TEMPLATE SRC - renders the TEMPLATE using data from SRC", + "json SRC - outputs a sequence diagram in JSON Graph Format (http://jsongraphformat.info/)", + "validate SRC - validates the input", + "", + "All commands print to stdout." + ] dfd :: FilePath -> IO () dfd path = do res <- readDiagramFile path case res of (Left err) -> print err - (Right diagram) -> putStr $ renderGraphviz $ asDFD diagram + (Right d) -> putStr $ GVR.renderGraphviz $ DFD.asDFD d seq' :: FilePath -> IO () seq' path = do res <- readDiagramFile path case res of (Left err) -> print err - (Right diagram) -> putStr $ renderPlantUML $ asSequenceDiagram diagram + (Right d) -> putStr $ PUR.renderPlantUML $ SEQ.asSequenceDiagram d +template :: FilePath -> FilePath -> IO () +template tmplPath path = do + res <- readDiagramFile path + tmplStr <- readFile tmplPath + case res of + (Left err) -> print err + (Right d) -> HR.renderTemplate tmplStr path d >>= TL.putStr +json :: FilePath -> IO () +json path = do + res <- readDiagramFile path + case res of + (Left err) -> print err + (Right d) -> BC.putStrLn $ JG.renderJSONGraph d + +validate :: FilePath -> IO () +validate path = do + res <- readDiagramFile path + case res of + (Left err) -> print err + (Right _) -> return () + main :: IO () main = do args <- getArgs case args of ["dfd", path] -> dfd path ["seq", path] -> seq' path - _ -> fail usage + ["template", tmplPath, path] -> template tmplPath path + ["json", path] -> json path + ["validate", path] -> validate path + ["--help"] -> usage + _ -> do hPutStrLn stderr "Invalid command!\n\nRun with --help to see usage." + exitWith $ ExitFailure 1 diff --git a/dataflow.cabal b/dataflow.cabal --- a/dataflow.cabal +++ b/dataflow.cabal @@ -1,5 +1,5 @@ name: dataflow -version: 0.6.1.0 +version: 0.7.1.0 synopsis: Generate Graphviz documents from a Haskell representation. description: Render graphs using a declarative markup. Currently supports DFD (http://en.wikipedia.org/wiki/Data_flow_diagram) @@ -18,9 +18,12 @@ examples/webapp.flow, examples/webapp.seq.png, examples/webapp.dfd.png, + examples/webapp.html, examples/legend.flow, examples/legend.seq.png, examples/legend.dfd.png, + examples/legend.html, + examples/template.ha, examples/Makefile cabal-version: >=1.10 @@ -31,6 +34,7 @@ library exposed-modules: DataFlow.Core, + DataFlow.Attributes, DataFlow.Reader, DataFlow.PrettyRenderer, DataFlow.Graphviz, @@ -39,20 +43,33 @@ DataFlow.PlantUML, DataFlow.PlantUML.Renderer, DataFlow.SequenceDiagram, - DataFlow.DFD + DataFlow.DFD, + DataFlow.Hastache.Renderer, + DataFlow.JSONGraphFormat, + DataFlow.JSONGraphFormat.Renderer build-depends: - base >=4 && <4.8, + base >=4 && < 5, mtl >=2.2, containers >= 0.4, MissingH, - parsec >= 3.1.9 + parsec >= 3.1.9, + filepath >= 1.3.0, + text >= 1.0, + blaze-html >= 0.8.0.2, + markdown >= 0.1.13.2, + hastache >= 0.6.1, + bytestring >= 0.10, + vector >= 0.11, + aeson >= 0.9.0.1 hs-source-dirs: src default-language: Haskell2010 executable dataflow main-is: Main.hs build-depends: - base >=4 && <4.8, + base >=4 && < 5, + text >= 1.0, + bytestring >= 0.10, dataflow hs-source-dirs: cli default-language: Haskell2010 @@ -63,8 +80,13 @@ default-language: Haskell98 hs-source-dirs: test build-depends: - base, + base >=4 && < 5, + containers >= 0.4, + parsec >= 3.1.9, HUnit, hspec == 2.*, + vector >= 0.11, + aeson >= 0.9.0.1, + bytestring >= 0.10, dataflow ghc-options: -Wall diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,6 +1,9 @@ SOURCES=$(shell find *.flow) DFD_TARGETS=$(SOURCES:%.flow=%.dfd.png) SEQ_TARGETS=$(SOURCES:%.flow=%.seq.png) +HTML_TARGETS=$(SOURCES:%.flow=%.html) +HTML_TEMPLATE=template.ha +JSON_TARGETS=$(SOURCES:%.flow=%.json) DATAFLOW=../dist/build/DataFlow/dataflow PLANTUML=/tmp/dataflow-build/plantuml.jar @@ -19,9 +22,21 @@ @echo "$< -> $@" @$(DATAFLOW) seq $< | java -Djava.awt.headless=true -jar $(PLANTUML) -tpng -pipe > $@ +%.html: %.flow $(DATAFLOW) $(HTML_TEMPLATE) + @echo "$< -> $@" + @$(DATAFLOW) template $(HTML_TEMPLATE) $< > $@ + +%.json: %.flow $(DATAFLOW) + @echo "$< -> $@" + @$(DATAFLOW) json $< > $@ + png: $(DFD_TARGETS) $(SEQ_TARGETS) +html: $(HTML_TARGETS) + +json: $(JSON_TARGETS) + clean: rm -f $(DFD_TARGETS) $(SEQ_TARGETS) -all: png +all: png html json diff --git a/examples/legend.dfd.png b/examples/legend.dfd.png Binary files a/examples/legend.dfd.png and b/examples/legend.dfd.png differ diff --git a/examples/legend.flow b/examples/legend.flow --- a/examples/legend.flow +++ b/examples/legend.flow @@ -1,11 +1,30 @@ -diagram '' { - boundary 'boundary' { - function f 'function' - database d 'database' - io i 'io' +diagram { + title = "Legend" + + boundary { + title = "A boundary" + + function f { + title = "function" + } + database d { + title = "database" + } + io i { + title = "io" + } } - f -> d 'Operation' 'Data' - i -> f '' 'Data' - f -> i 'Operation' '' + f -> d { + action = "Operation" + data = "Data" + } + i -> f { + data = "Data" + } + f -> i { + action = "Operation" + data = `Some data, + and other data.` + } } diff --git a/examples/legend.html b/examples/legend.html new file mode 100644 --- /dev/null +++ b/examples/legend.html @@ -0,0 +1,37 @@ + + + + + Legend + + +

Legend

+ + + +Sequence Diagram + +
    +
  1. + +

    Data: Data

    + +
    2. +
  2. + +

    Data: Data

    + +
    3. +
  3. + +

    Data: Some data, +and other data.

    + +
    4. +
+ +

Threats

+ + + + diff --git a/examples/legend.seq.png b/examples/legend.seq.png Binary files a/examples/legend.seq.png and b/examples/legend.seq.png differ diff --git a/examples/template.ha b/examples/template.ha new file mode 100644 --- /dev/null +++ b/examples/template.ha @@ -0,0 +1,42 @@ + + + + + {{title}} + + +

{{title}}

+ +{{#description}} +

{{{description}}}

+{{/description}} + + +Sequence Diagram + +
    +{{#flows}} +
  1. + {{#operation}} +

    {{{operation}}}

    + {{/operation}} + + {{#data}} +

    Data: {{{data}}}

    + {{/data}} + + {{#description}} +

    {{#html_linebreaks}}description{{/html_linebreaks}}

    + {{/description}} +
    2. +{{/flows}} +
+ +

Threats

+ +{{#threats}} +

{{#markdown}}threats{{/markdown}}

+{{/threats}} + + + diff --git a/examples/webapp.dfd.png b/examples/webapp.dfd.png Binary files a/examples/webapp.dfd.png and b/examples/webapp.dfd.png differ diff --git a/examples/webapp.flow b/examples/webapp.flow --- a/examples/webapp.flow +++ b/examples/webapp.flow @@ -1,15 +1,52 @@ -diagram 'Webapp' { - boundary 'Browser' { - function client 'Client' +diagram { + title = "Webapp" + + threats = ` + No particular threats at this point. + + It's **extremely** safe.` + + boundary { + title = "Browser" + + function client { + title = "Client" + } } - boundary 'Amazon AWS' { - function server 'Web Server' - database logs 'Logs' + + boundary { + title = "Amazon AWS" + + function server { + title = "Web Server" + } + database logs { + title = "Logs" + } } - io analytics 'Google
Analytics' + io analytics { + title = "Google Analytics" + } - client -> server 'Request /' '' - server -> logs 'Log' 'User IP' - server -> client 'Response' 'User Profile' - analytics <- client 'Log' 'Page
Navigation' + client -> server { + operation = "Request /" + description = `User navigates with a browser to see some content.` + } + server -> logs { + operation = "Log" + data = `The user + IP address.` + description = `Logged to a ELK stack.` + } + server -> client { + operation = "Response" + data = "User Profile" + description = `The server responds with some HTML.` + } + analytics <- client { + operation = "Log" + data = "Page Navigation" + description = `The Google Analytics plugin sends navigation + data to Google.` + } } diff --git a/examples/webapp.html b/examples/webapp.html new file mode 100644 --- /dev/null +++ b/examples/webapp.html @@ -0,0 +1,50 @@ + + + + + Webapp + + +

Webapp

+ + + +Sequence Diagram + +
    +
  1. +

    Request /

    + + +

    User navigates with a browser to see some content.

    +
    2. +
  2. +

    Log

    + +

    Data: The user +IP address.

    + +

    Logged to a ELK stack.

    +
    3. +
  3. +

    Response

    + +

    Data: User Profile

    + +

    The server responds with some HTML.

    +
    4. +
  4. +

    Log

    + +

    Data: Page Navigation

    + +

    The Google Analytics plugin sends navigation
    data to Google.

    +
    5. +
+ +

Threats

+ +

No particular threats at this point.

It's extremely safe.

+ + + diff --git a/examples/webapp.seq.png b/examples/webapp.seq.png Binary files a/examples/webapp.seq.png and b/examples/webapp.seq.png differ diff --git a/src/DataFlow/Attributes.hs b/src/DataFlow/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/Attributes.hs @@ -0,0 +1,11 @@ +module DataFlow.Attributes where + +import qualified Data.Map as M + +import DataFlow.Core + +getTitleOrBlank :: Attributes -> String +getTitleOrBlank = M.findWithDefault "" "title" + +getTitle :: Attributes -> Maybe String +getTitle = M.lookup "title" diff --git a/src/DataFlow/Core.hs b/src/DataFlow/Core.hs --- a/src/DataFlow/Core.hs +++ b/src/DataFlow/Core.hs @@ -1,33 +1,40 @@ module DataFlow.Core ( ID, - Name, - Operation, - Description, + Attributes, Diagram(..), - Object(..) + RootNode(..), + Flow(..), + Node(..) ) where +import Data.Map as M + -- | An identifier corresponding to those in Graphviz. type ID = String --- | The name of a 'Diagram' or 'Object'. -type Name = String --- | Operation heading. -type Operation = String --- | Operation description. -type Description = String +type Attributes = M.Map String String + -- | The top level diagram. -data Diagram = Diagram (Maybe Name) [Object] deriving (Eq, Show) +data Diagram = Diagram Attributes [RootNode] [Flow] + deriving (Eq, Show) --- | An object in a diagram. -data Object = +-- | An root node in a diagram. +data RootNode = + -- | A top level Node. + Node Node + -- | Surrounds other non-root nodes, denoting a boundary. + | TrustBoundary Attributes [Node] + deriving (Eq, Show) + +data Node = -- | A "Input" or "Output" in DFD. - InputOutput ID Name - -- | Surrounds other objects, denoting a boundary. - | TrustBoundary ID Name [Object] + InputOutput ID Attributes -- | A \"Function\" in DFD. - | Function ID Name + | Function ID Attributes -- | A \"Database\" in DFD. - | Database ID Name - -- | Describes the flow of data between two objects. - | Flow ID ID Operation Description deriving (Show, Eq) + | Database ID Attributes + deriving (Show, Eq) + +-- | Describes the flow of data between two nodes. +data Flow = Flow ID ID Attributes + deriving (Show, Eq) diff --git a/src/DataFlow/DFD.hs b/src/DataFlow/DFD.hs --- a/src/DataFlow/DFD.hs +++ b/src/DataFlow/DFD.hs @@ -3,22 +3,35 @@ import Text.Printf import Control.Monad import Control.Monad.State +import qualified Data.Map as M + import qualified DataFlow.Core as C +import DataFlow.Attributes import DataFlow.Graphviz import DataFlow.Graphviz.EdgeNormalization -type Step = Int -type DFD v = State Step v +data DFDState = DFDState { step :: Int, clusterID :: Int } +type DFD v = State DFDState v incrStep :: DFD () -incrStep = modify (+ 1) +incrStep = modify f + where f s = DFDState (step s + 1) (clusterID s) +incrClusterID :: DFD () +incrClusterID = modify f + where f s = DFDState (step s) (clusterID s + 1) + -- | Get the next \"step\" number (the order of flow arrows in the diagram). nextStep :: DFD Int nextStep = do incrStep - get + liftM step get +nextClusterID :: DFD Int +nextClusterID = do + incrClusterID + liftM clusterID get + inQuotes :: String -> String inQuotes s = "\"" ++ s ++ "\"" @@ -45,57 +58,78 @@ color _ "" = "" color c s = printf "%s" c s -convertObject :: C.Object -> DFD StmtList +convertNode :: C.Node -> DFD StmtList -convertObject (C.InputOutput id' name) = return [ +convertNode (C.InputOutput id' attrs) = return [ NodeStmt id' [ Attr "shape" "square", Attr "style" "bold", - label $ printf "
%s
" (bold name) + label $ + printf "
%s
" + (bold $ getTitleOrBlank attrs) ] ] -convertObject (C.TrustBoundary id' name objects) = do - objectStmts <- convertObjects objects - let sgId = "cluster_" ++ id' - sgAttrStmt = AttrStmt Graph [ - Attr "fontsize" "10", - Attr "fontcolor" "grey35", - Attr "style" "dashed", - Attr "color" "grey35", - label $ italic name - ] - stmts = sgAttrStmt : objectStmts - return [SubgraphStmt $ Subgraph sgId stmts] - -convertObject (C.Function id' name) = return [ +convertNode (C.Function id' attrs) = return [ NodeStmt id' [ Attr "shape" "circle", - label $ bold name + label $ bold $ getTitleOrBlank attrs ] ] -convertObject (C.Database id' name) = return [ +convertNode (C.Database id' attrs) = return [ NodeStmt id' [ Attr "shape" "none", - label $ printf "
%s
" (bold name) + label $ printf "
%s
" + (bold $ getTitleOrBlank attrs) ] ] -convertObject (C.Flow i1 i2 op desc) = do - step <- nextStep - let stepStr = color "#3184e4" $ bold $ printf "(%d) " step +convertNodes :: [C.Node] -> DFD StmtList +convertNodes = liftM concat . mapM convertNode + +convertFlow :: C.Flow -> DFD StmtList +convertFlow (C.Flow i1 i2 attrs) = do + s <- nextStep + let stepStr = color "#3184e4" $ bold $ printf "(%d) " s + let text = case (M.lookup "operation" attrs, M.lookup "data" attrs) of + (Just op, Just d) -> bold op ++ "
" ++ small d + (Just op, Nothing) -> bold op + (Nothing, Just d) -> small d + _ -> "" return [ EdgeStmt (EdgeExpr (IDOperand (NodeID i1 Nothing)) Arrow (IDOperand (NodeID i2 Nothing))) [ - label $ stepStr ++ bold op ++ "
" ++ small desc + label $ stepStr ++ text ] ] -convertObjects :: [C.Object] -> DFD StmtList -convertObjects = liftM concat . mapM convertObject +convertFlows :: [C.Flow] -> DFD StmtList +convertFlows = liftM concat . mapM convertFlow +convertRootNode :: C.RootNode -> DFD StmtList +convertRootNode (C.TrustBoundary attrs nodes) = do + nodeStmts <- convertNodes nodes + id' <- nextClusterID + let sgId = "cluster_" ++ show id' + defaultSgAttrs = [ + Attr "fontsize" "10", + Attr "fontcolor" "grey35", + Attr "style" "dashed", + Attr "color" "grey35"] + sgAttrs = case getTitle attrs of + Just title -> defaultSgAttrs ++ [label $ italic title] + Nothing -> defaultSgAttrs + sgAttrStmt = AttrStmt Graph sgAttrs + stmts = sgAttrStmt : nodeStmts + return [SubgraphStmt $ Subgraph sgId stmts] + +convertRootNode (C.Node n) = convertNode n + +convertRootNodes :: [C.RootNode] -> DFD StmtList +convertRootNodes = liftM concat . mapM convertRootNode + defaultGraphStmts :: StmtList defaultGraphStmts = [ AttrStmt Graph [ @@ -117,18 +151,19 @@ EqualsStmt "rankdir" "t" ] -convertDiagram :: C.Diagram -> DFD Graph -convertDiagram (C.Diagram (Just name) objects) = do - let lbl = EqualsStmt "label" (inAngleBrackets $ bold name) - objs <- convertObjects objects - let stmts = lbl : defaultGraphStmts ++ objs - return $ normalize $ Digraph (inQuotes name) stmts - -convertDiagram (C.Diagram Nothing objects) = do - objs <- convertObjects objects - return $ normalize $ Digraph "Untitled" $ defaultGraphStmts ++ objs +convertDiagram :: C.Diagram -> DFD Graph +convertDiagram (C.Diagram attrs rootNodes flows) = do + n <- convertRootNodes rootNodes + f <- convertFlows flows + return $ case M.lookup "title" attrs of + Just title -> + let lbl = EqualsStmt "label" (inAngleBrackets $ bold title) + stmts = lbl : defaultGraphStmts ++ n ++ f + in normalize $ Digraph (inQuotes title) stmts + Nothing -> + normalize $ Digraph "Untitled" $ defaultGraphStmts ++ n ++ f asDFD :: C.Diagram -> Graph -asDFD d = evalState (convertDiagram d) 0 +asDFD d = evalState (convertDiagram d) DFDState { step = 0, clusterID = 0 } diff --git a/src/DataFlow/Graphviz/Renderer.hs b/src/DataFlow/Graphviz/Renderer.hs --- a/src/DataFlow/Graphviz/Renderer.hs +++ b/src/DataFlow/Graphviz/Renderer.hs @@ -6,15 +6,20 @@ ) where import Data.Char +import Data.List.Utils import Text.Printf + import DataFlow.PrettyRenderer import DataFlow.Graphviz +convertNewline :: String -> String +convertNewline = replace "\n" "
" + class Renderable t where render :: t -> Renderer () instance Renderable Attr where - render (Attr i1 i2) = writeln $ printf "%s = %s;" i1 i2 + render (Attr i1 i2) = writeln $ printf "%s = %s;" i1 (convertNewline i2) instance Renderable AttrList where render = mapM_ render diff --git a/src/DataFlow/Hastache/Renderer.hs b/src/DataFlow/Hastache/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/Hastache/Renderer.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +module DataFlow.Hastache.Renderer (renderTemplate) where + +import Data.List.Utils +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import System.FilePath (dropExtension, takeFileName) +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Hastache +import Text.Hastache.Context +import Text.Markdown (markdown, def) + +import DataFlow.Core + +mkContextWithDefaults :: Attributes -> (String -> MuType IO) -> MuContext IO +mkContextWithDefaults attrs f = + mkStrContext $ \key -> case f key of + MuNothing -> defaults key + v -> v + where + defaults "markdown" = MuLambda markdownAttr + defaults "html_linebreaks" = MuLambda htmlLinebreaksAttr + defaults key = case M.lookup key attrs of + (Just v) -> MuVariable v + _ -> MuNothing + + markdownAttr :: T.Text -> TL.Text + markdownAttr t = + let key = T.unpack t + value = M.lookup key attrs + in case value of + (Just s) -> renderHtml $ markdown def $ TL.pack s + _ -> "" + htmlLinebreaksAttr t = + let key = T.unpack t + value = M.lookup key attrs + in case value of + (Just s) -> replace "\n" "
" s + _ -> "" + +mkFlowContext :: Flow -> MuContext IO +mkFlowContext (Flow _ _ attrs) = mkContextWithDefaults attrs (const MuNothing) + +mkDiagramContext :: FilePath -> Diagram -> MuContext IO +mkDiagramContext fp (Diagram attrs _ flows) = + mkContextWithDefaults attrs ctx + where + ctx "filename_without_extension" = MuVariable $ dropExtension $ takeFileName fp + ctx "flows" = MuList $ map mkFlowContext flows + ctx _ = MuNothing + +renderTemplate :: String -> FilePath -> Diagram -> IO TL.Text +renderTemplate tmpl fp d = + hastacheStr defaultConfig (encodeStr tmpl) (mkDiagramContext fp d) diff --git a/src/DataFlow/JSONGraphFormat.hs b/src/DataFlow/JSONGraphFormat.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/JSONGraphFormat.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +module DataFlow.JSONGraphFormat ( + Metadata(), + Document(..), + Graph(..), + Node(..), + Edge(..) + ) where + +import Data.Aeson +import Data.Aeson.Types (Pair) +import qualified Data.Map as M +import Data.Vector (fromList) + +type Metadata = M.Map String String + +data Document = SingleGraph { graph :: Graph } + | MultiGraph { graphs :: [Graph] } + +instance ToJSON Document where + toJSON (SingleGraph g) = object [ + "graph" .= toJSON g + ] + toJSON (MultiGraph gs) = object [ + "graphs" .= (Array $ fromList $ map toJSON gs) + ] + +data Graph = Graph { nodes :: [Node] + , edges :: [Edge] + , graphLabel :: Maybe String + , graphMetadata :: Metadata + } + +instance ToJSON Graph where + toJSON (Graph nodes edges lbl metadata) = object $ + labelField lbl ++ [ + "nodes" .= Array (fromList $ map toJSON nodes), + "edges" .= Array (fromList $ map toJSON edges), + "metadata" .= toJSON metadata + ] + +data Node = Node { id :: String + , nodeLabel :: Maybe String + , nodeMetadata :: Metadata } + +instance ToJSON Node where + toJSON (Node id' lbl metadata) = object $ + labelField lbl ++ [ + "id" .= toJSON id', + "metadata" .= toJSON metadata + ] + +data Edge = Edge { source :: String + , target :: String + , edgeLabel :: Maybe String + , edgeMetadata :: Metadata } + +instance ToJSON Edge where + toJSON (Edge source target lbl metadata) = object $ + labelField lbl ++ [ + "source" .= toJSON source, + "target" .= toJSON target, + "metadata" .= toJSON metadata + ] + +labelField :: Maybe String -> [Pair] +labelField (Just s) = [("label", toJSON s)] +labelField _ = [] diff --git a/src/DataFlow/JSONGraphFormat/Renderer.hs b/src/DataFlow/JSONGraphFormat/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/JSONGraphFormat/Renderer.hs @@ -0,0 +1,46 @@ +module DataFlow.JSONGraphFormat.Renderer (convertDiagram, renderJSONGraph) where + +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as M + +import DataFlow.Core +import qualified DataFlow.JSONGraphFormat as JG + +withLabelAndMetadataFrom :: (Maybe String -> JG.Metadata -> v) -> Attributes -> v +f `withLabelAndMetadataFrom` attrs = f (M.lookup "title" attrs) (M.delete "title" attrs) + +addType :: String -> JG.Metadata -> JG.Metadata +addType = M.insert "type" + +addBoundary :: Maybe String -> JG.Metadata -> JG.Metadata +addBoundary (Just b) m = M.insert "trust-boundary" b m +addBoundary Nothing m = m + +convertNode :: Maybe String -> Node -> JG.Node +convertNode b (InputOutput id attrs) = + JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "io" attrs) +convertNode b (Function id attrs) = + JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "function" attrs) +convertNode b (Database id attrs) = + JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "database" attrs) + +convertRootNode :: RootNode -> [JG.Node] +convertRootNode (Node node) = [convertNode Nothing node] +-- TODO: replace title attribute with mandatory ID for boundaries +convertRootNode (TrustBoundary attrs nodes) = + map (convertNode (M.lookup "title" attrs)) nodes + +convertFlow :: Flow -> JG.Edge +convertFlow (Flow source target attrs) = + JG.Edge source target `withLabelAndMetadataFrom` attrs + +convertDiagram :: Diagram -> JG.Document +convertDiagram (Diagram attrs rootNodes flows) = + let nodes = concatMap convertRootNode rootNodes + edges = map convertFlow flows + graph = JG.Graph nodes edges `withLabelAndMetadataFrom` attrs + in JG.SingleGraph graph + +renderJSONGraph :: Diagram -> ByteString +renderJSONGraph = encode . convertDiagram diff --git a/src/DataFlow/Reader.hs b/src/DataFlow/Reader.hs --- a/src/DataFlow/Reader.hs +++ b/src/DataFlow/Reader.hs @@ -1,11 +1,14 @@ -module DataFlow.Reader (readDiagram, readDiagramFile) where +module DataFlow.Reader where -import Text.ParserCombinators.Parsec +import Control.Monad +import Data.Functor ((<$>)) +import Control.Applicative ((<*>)) import Data.Char -import DataFlow.Core +import Data.List +import qualified Data.Map as M +import Text.ParserCombinators.Parsec -nameToID :: String -> String -nameToID = filter isLetter . map toLower +import DataFlow.Core identifier :: Parser ID identifier = do @@ -13,49 +16,66 @@ rest <- many (letter <|> digit <|> char '_') return $ first : rest -quoted :: Parser ID -quoted = do +str :: Parser String +str = do -- TODO: Handle escaped characters. - _ <- char '\'' - s <- many (noneOf "'") - _ <- char '\'' + _ <- char '"' + s <- many (noneOf "\"\r\n") + _ <- char '"' return s -skipWhitespace :: Parser () -skipWhitespace = skipMany $ space <|> newline - -skipWhitespace1 :: Parser () -skipWhitespace1 = skipMany $ space <|> newline +textBlock :: Parser String +textBlock = do + _ <- char '`' + s <- anyToken `manyTill` try (char '`') + return $ intercalate "\n" $ map (dropWhile isSpace) $ lines s inBraces :: Parser t -> Parser t inBraces inside = do - skipWhitespace + spaces _ <- char '{' - skipWhitespace + spaces c <- inside - skipWhitespace + spaces _ <- char '}' - skipWhitespace + spaces return c -idAndNameObject :: String -> (ID -> ID -> t) -> Parser t -idAndNameObject keyword f = do +attr :: Parser (String, String) +attr = do + key <- identifier + skipMany1 $ char ' ' + _ <- char '=' + skipMany1 $ char ' ' + value <- try textBlock <|> str + spaces + return (key, value) + +attrs :: Parser Attributes +attrs = liftM M.fromList $ many (try attr) + +-- | Construct a parser for an node with an ID: +-- +-- @ +-- \ \ { +-- ... +-- } +-- @ +idAndAttrsNode :: String -> (ID -> Attributes -> t) -> Parser t +idAndAttrsNode keyword f = do _ <- string keyword skipMany1 space id' <- identifier - skipMany1 space - name <- quoted - skipWhitespace1 - return $ f id' name + f id' <$> option M.empty (try (inBraces attrs)) -function :: Parser Object -function = idAndNameObject "function" Function +function :: Parser Node +function = idAndAttrsNode "function" Function -database :: Parser Object -database = idAndNameObject "database" Database +database :: Parser Node +database = idAndAttrsNode "database" Database -io :: Parser Object -io = idAndNameObject "io" InputOutput +io :: Parser Node +io = idAndAttrsNode "io" InputOutput data FlowType = Back | Forward @@ -67,64 +87,41 @@ "<-" -> return Back _ -> fail "Invalid flow statement" -flow :: Parser Object +flow :: Parser Flow flow = do i1 <- identifier skipMany1 space - a <- arrow + arr <- arrow skipMany1 space i2 <- identifier - skipMany1 space - data' <- quoted - skipMany1 space - desc <- quoted - skipWhitespace1 - case a of - Back -> return $ Flow i2 i1 data' desc - Forward -> return $ Flow i1 i2 data' desc + a <- option M.empty $ try (inBraces attrs) + case arr of + Back -> return $ Flow i2 i1 a + Forward -> return $ Flow i1 i2 a -boundary :: Parser Object +node :: Parser Node +node = do + n <- try function + <|> try database + <|> io + spaces + return n + +boundary :: Parser RootNode boundary = do _ <- string "boundary" - skipMany1 space - name <- quoted - let id' = nameToID name - skipMany1 space - objs <- inBraces objects - skipWhitespace1 - return $ TrustBoundary id' name objs - -object :: Parser Object -object = - try boundary - <|> try function - <|> try database - <|> try io - <|> flow - -objects :: Parser [Object] -objects = object `sepBy` many (space <|> newline) - -namedDiagram :: Parser Diagram -namedDiagram = do - _ <- string "diagram" - skipMany1 space - name <- quoted - skipMany1 space - objs <- inBraces objects - return $ Diagram (Just name) objs + inBraces (TrustBoundary <$> attrs <*> many node) -unnamedDiagram :: Parser Diagram -unnamedDiagram = do - _ <- string "diagram" - skipMany1 space - objs <- inBraces objects - return $ Diagram Nothing objs +rootNode :: Parser RootNode +rootNode = try (Node <$> node) + <|> boundary diagram :: Parser Diagram -diagram = try unnamedDiagram <|> namedDiagram +diagram = do + _ <- string "diagram" + inBraces (Diagram <$> attrs <*> many (try rootNode) <*> many flow) -readDiagram :: String -> String -> Either ParseError Diagram +readDiagram :: String -> String -> Either ParseError Diagram readDiagram = parse diagram readDiagramFile :: FilePath -> IO (Either ParseError Diagram) diff --git a/src/DataFlow/SequenceDiagram.hs b/src/DataFlow/SequenceDiagram.hs --- a/src/DataFlow/SequenceDiagram.hs +++ b/src/DataFlow/SequenceDiagram.hs @@ -1,12 +1,15 @@ module DataFlow.SequenceDiagram where +import qualified Data.Map as M +import Data.List.Utils import Text.Printf + import qualified DataFlow.Core as C +import DataFlow.Attributes import DataFlow.PlantUML -import Data.List.Utils convertNewline :: String -> String -convertNewline = replace "
" "\\n" +convertNewline = replace "\n" "\\n" bold :: String -> String bold "" = "" @@ -19,17 +22,18 @@ join "\\n" $ map italic' $ split "\\n" s where italic' = printf "%s" -convertObject :: C.Object -> Stmt -convertObject (C.InputOutput id' name) = - Entity id' $ convertNewline name -convertObject (C.TrustBoundary _ name objects) = - Box (convertNewline name) $ map convertObject objects -convertObject (C.Function id' name) = - Participant id' $ convertNewline name -convertObject (C.Database id' name) = - Database id' $ convertNewline name -convertObject (C.Flow i1 i2 op desc) = - let p = (convertNewline (bold op), italic $ convertNewline desc) +convertNode :: C.Node -> Stmt +convertNode (C.InputOutput id' attrs) = + Entity id' $ convertNewline $ getTitleOrBlank attrs +convertNode (C.Function id' attrs) = + Participant id' $ convertNewline $ getTitleOrBlank attrs +convertNode (C.Database id' attrs) = + Database id' $ convertNewline $ getTitleOrBlank attrs + +convertFlow :: C.Flow -> Stmt +convertFlow (C.Flow i1 i2 attrs) = + let p = (convertNewline (bold $ M.findWithDefault "" "operation" attrs), + italic $ convertNewline (M.findWithDefault "" "data" attrs)) s = case p of ("", "") -> "" ("", d) -> d @@ -37,6 +41,11 @@ (o, d) -> o ++ "\\n" ++ d in Edge i1 i2 s +convertRootNode :: C.RootNode -> Stmt +convertRootNode (C.TrustBoundary attrs nodes) = + Box (convertNewline $ M.findWithDefault "Untitled" "title" attrs) $ map convertNode nodes +convertRootNode (C.Node n) = convertNode n + defaultSkinParams :: [Stmt] defaultSkinParams = [ SkinParam "BackgroundColor" "#white", @@ -79,5 +88,7 @@ ] asSequenceDiagram :: C.Diagram -> Diagram -asSequenceDiagram (C.Diagram _ objects) = - SequenceDiagram $ defaultSkinParams ++ map convertObject objects +asSequenceDiagram (C.Diagram _ rootNodes flows) = + SequenceDiagram $ defaultSkinParams + ++ map convertRootNode rootNodes + ++ map convertFlow flows