dataflow 0.7.1.0 → 0.7.3.0

raw patch · 21 files changed

+408/−143 lines, 21 filesdep +gitrevPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: gitrev

API changes (from Hackage documentation)

Files

• README.md +29/−5
• cli/Main.hs +38/−14
• dataflow.cabal +3/−1
• examples/legend.dfd.png binary
• examples/legend.flow +15/−7
• examples/legend.html +27/−7
• examples/legend.seq.png binary
• examples/template.ha +17/−4
• examples/webapp.dfd.png binary
• examples/webapp.flow +17/−8
• examples/webapp.html +35/−13
• examples/webapp.seq.png binary
• src/DataFlow/Attributes.hs +3/−2
• src/DataFlow/Core.hs +13/−2
• src/DataFlow/DFD.hs +24/−25
• src/DataFlow/Hastache/Renderer.hs +16/−6
• src/DataFlow/JSONGraphFormat.hs +12/−4
• src/DataFlow/JSONGraphFormat/Renderer.hs +29/−13
• src/DataFlow/Reader.hs +61/−26
• src/DataFlow/SequenceDiagram.hs +14/−6
• src/DataFlow/Validation.hs +55/−0

@@ -42,7 +42,7 @@   textblock` ``` -... would render as:+... is converted to:  ``` this is@@ -50,6 +50,15 @@ textblock ``` +#### Arrays++Arrays can contain other values (arrays, strings, text blocks).++```dot+["hello", "world", ["I", "am", `nested+                                here`]]+```+ #### Attributes  Attributes are key-value pairs for diagrams and nodes that are used by@@ -63,6 +72,7 @@   key1 = "attr value"   key2 = `attr           value`+  key3 = ["value1", "value2"] } ``` @@ -81,11 +91,11 @@  The `boundary` form declares a TrustBoundary node that can contain attributes and other nodes. Boundaries are only allowed in the top-level-diagram.+diagram and they must have unique IDs.  ```dot diagram {-  boundary {+  boundary my_boundary {     title = "My System"   } }@@ -127,6 +137,19 @@ } ``` +#### Comment++Comments are written using `/*` and `*/` and are ignored by the Reader. They're+only used for human consumption.++```dot+diagram {+  /* I can write+   * whatever I+   * want in here! */+}+```+ ## Example  The image from the top of this README is rendered from the following DataFlow@@ -136,6 +159,7 @@ diagram {   title = "Webapp" +  /* Some comment about this... */   threats = `     No particular threats at this point. @@ -257,12 +281,12 @@   ```  * `flows` - a list of all the Flow nodes in the diagram. Attributes of the-  flow is accessible inside the iteration scope.+  flow is accessible inside the iteration scope, including a `number`.    ```mustache   <ol>   {{#flows}}-    <li>{{description}}</li>+    <li>{{number}} - {{description}}</li>   {{/flows}}   </ol>   ```

@@ -1,12 +1,16 @@+{-# LANGUAGE TemplateHaskell #-} module Main where +import Development.GitRev+import qualified Data.ByteString.Lazy.Char8 as BC+import qualified Data.Text.Lazy.IO as TL import System.IO import System.Environment import System.Exit-import qualified Data.ByteString.Lazy.Char8 as BC-import qualified Data.Text.Lazy.IO as TL  import DataFlow.Reader+import DataFlow.Core+import qualified DataFlow.Validation as V import qualified DataFlow.DFD as DFD import qualified DataFlow.SequenceDiagram as SEQ import qualified DataFlow.Graphviz.Renderer as GVR@@ -23,48 +27,67 @@     "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/)",+    "json SRC              - outputs a sequence diagram in JSON Graph Format",+    "                        (http://jsongraphformat.info/)",     "validate SRC          - validates the input",     "",-    "All commands print to stdout."+    "--version             - display VCS information",+    "--help                - display this help message",+    "",+    "All commands print to stdout"   ] +showErrors :: Show s => Either [s] v -> Either String v+showErrors = either (Left . unlines . map show) Right++readAndValidate :: FilePath -> IO (Either String Diagram)+readAndValidate path = do+  res <- readDiagramFile path+  case res of+    (Left err) -> return $ Left $ show err+    (Right d) -> return (showErrors $ V.validate d)+ dfd :: FilePath -> IO () dfd path = do-  res <- readDiagramFile path+  res <- readAndValidate path   case res of-    (Left err) -> print err+    (Left err) -> putStrLn err     (Right d) -> putStr $ GVR.renderGraphviz $ DFD.asDFD d  seq' :: FilePath -> IO () seq' path = do-  res <- readDiagramFile path+  res <- readAndValidate path   case res of-    (Left err) -> print err+    (Left err) -> putStrLn err     (Right d) -> putStr $ PUR.renderPlantUML $ SEQ.asSequenceDiagram d  template :: FilePath -> FilePath -> IO () template tmplPath path = do-  res <- readDiagramFile path+  res <- readAndValidate path   tmplStr <- readFile tmplPath   case res of-    (Left err) -> print err+    (Left err) -> putStrLn err     (Right d) -> HR.renderTemplate tmplStr path d >>= TL.putStr  json :: FilePath -> IO () json path = do-  res <- readDiagramFile path+  res <- readAndValidate path   case res of-    (Left err) -> print err+    (Left err) -> putStrLn err     (Right d) -> BC.putStrLn $ JG.renderJSONGraph d  validate :: FilePath -> IO () validate path = do-  res <- readDiagramFile path+  res <- readAndValidate path   case res of-    (Left err) -> print err+    (Left err) -> putStrLn err     (Right _) -> return () +version :: IO ()+version = do+  putStrLn $ "Branch: " ++ $(gitBranch)+  putStrLn $ "Hash:   " ++ $(gitHash)+ main :: IO () main = do   args <- getArgs@@ -74,6 +97,7 @@     ["template", tmplPath, path] -> template tmplPath path     ["json", path] -> json path     ["validate", path] -> validate path+    ["--version"] -> version     ["--help"] -> usage     _ -> do hPutStrLn stderr "Invalid command!\n\nRun with --help to see usage."             exitWith $ ExitFailure 1

@@ -1,5 +1,5 @@ name:                dataflow-version:             0.7.1.0+version:             0.7.3.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)@@ -35,6 +35,7 @@   exposed-modules:     DataFlow.Core,     DataFlow.Attributes,+    DataFlow.Validation,     DataFlow.Reader,     DataFlow.PrettyRenderer,     DataFlow.Graphviz,@@ -70,6 +71,7 @@     base >=4 && < 5,     text >= 1.0,     bytestring >= 0.10,+    gitrev >= 1.1.0,     dataflow   hs-source-dirs:      cli   default-language:    Haskell2010

binary file changed (24872 → 35473 bytes)

@@ -1,7 +1,12 @@+/*+ * legend.flow+ *+ * This is nice.+ */ diagram {   title = "Legend" -  boundary {+  boundary my_boundary {     title = "A boundary"      function f {@@ -16,15 +21,18 @@   }    f -> d {-    action = "Operation"-    data = "Data"+    operation = "Operation 1"+    data = ["Data"]   }   i -> f {-    data = "Data"+    operation = "Operation 2"+    data = ["Data"]   }   f -> i {-    action = "Operation"-    data = `Some data,-            and other data.`+    operation = "Operation 3"+    data = [+      "Some data",+      "Other data"+    ]   } }

@@ -3,6 +3,15 @@ <head>   <meta charset="UTF-8">   <title>Legend</title>++  <style>+  li h2 {+    font-size: 125%;+  }+  ul ul {+    list-style-type: upper-roman;+  }+  </style> </head> <body> <h1>Legend</h1>@@ -13,25 +22,36 @@  <ol>   <li>-    -        <p><strong>Data:</strong> Data</p>+        <h2>Operation 1</h2>     +    <ul>+          <li>Data</li>+        </ul>+       </li>   <li>-    -        <p><strong>Data:</strong> Data</p>+        <h2>Operation 2</h2>     +    <ul>+          <li>Data</li>+        </ul>+       </li>   <li>-    -        <p><strong>Data:</strong> Some data,-and other data.</p>+        <h2>Operation 3</h2>     +    <ul>+          <li>Some data</li>+          <li>Other data</li>+        </ul>+       </li> </ol>  <h2>Threats</h2> +<ul>+</ul>  </body> </html>

binary file changed (11159 → 12656 bytes)

@@ -3,12 +3,21 @@ <head>   <meta charset="UTF-8">   <title>{{title}}</title>++  <style>+  li h2 {+    font-size: 125%;+  }+  ul ul {+    list-style-type: upper-roman;+  }+  </style> </head> <body> <h1>{{title}}</h1>  {{#description}}-<p>{{{description}}}</p>+{{#markdown}}description{{/markdown}} {{/description}}  <img src="./{{filename_without_extension}}.dfd.png">@@ -18,12 +27,14 @@ {{#flows}}   <li>     {{#operation}}-    <p><strong>{{{operation}}}</strong></p>+    <h2>{{{operation}}}</h2>     {{/operation}} +    <ul>     {{#data}}-    <p><strong>Data:</strong> {{{data}}}</p>+      <li>{{value}}</li>     {{/data}}+    </ul>      {{#description}}     <p>{{#html_linebreaks}}description{{/html_linebreaks}}</p>@@ -34,9 +45,11 @@  <h2>Threats</h2> +<ul> {{#threats}}-<p>{{#markdown}}threats{{/markdown}}</p>+<li><code>{{value}}</code></li> {{/threats}}+</ul>  </body> </html>

binary file changed (48497 → 56729 bytes)

@@ -1,12 +1,18 @@ diagram {   title = "Webapp" -  threats = `-    No particular threats at this point.+  /* Some comment about this... */+  description = `+    No *particular* threats to consider at this point.      It's **extremely** safe.` -  boundary {+  threats = [+    "csrf",+    "mitm"+  ]++  boundary browser {     title = "Browser"      function client {@@ -14,7 +20,7 @@     }   } -  boundary {+  boundary aws {     title = "Amazon AWS"      function server {@@ -34,18 +40,21 @@   }   server -> logs {     operation = "Log"-    data = `The user-            IP address.`+    data = [+      "IP Address<sub>user</sub>",+      "Timestamp<sub>request</sub>",+      "Geolocation"+    ]     description = `Logged to a ELK stack.`   }   server -> client {     operation = "Response"-    data = "User Profile"+    data = ["User Profile"]     description = `The server responds with some HTML.`   }   analytics <- client {     operation = "Log"-    data = "Page Navigation"+    data = ["Page Navigation"]     description = `The Google Analytics plugin sends navigation                    data to Google.`   }

@@ -3,48 +3,70 @@ <head>   <meta charset="UTF-8">   <title>Webapp</title>++  <style>+  li h2 {+    font-size: 125%;+  }+  ul ul {+    list-style-type: upper-roman;+  }+  </style> </head> <body> <h1>Webapp</h1> +<p>No <i>particular</i> threats to consider at this point.</p><p>It's <b>extremely</b> safe.</p>  <img src="./webapp.dfd.png"> <a href="./webapp.seq.png">Sequence Diagram</a>  <ol>   <li>-        <p><strong>Request /</strong></p>-    +        <h2>Request /</h2>     +    <ul>+        </ul>+         <p>User navigates with a browser to see some content.</p>       </li>   <li>-        <p><strong>Log</strong></p>-    -        <p><strong>Data:</strong> The user-IP address.</p>+        <h2>Log</h2>     +    <ul>+          <li>IP Address&lt;sub&gt;OMG&lt;/sub&gt;</li>+          <li>Timestamp&lt;sub&gt;OMG&lt;/sub&gt;</li>+          <li>Geolocation&lt;sub&gt;OMG&lt;/sub&gt;</li>+        </ul>+         <p>Logged to a ELK stack.</p>       </li>   <li>-        <p><strong>Response</strong></p>-    -        <p><strong>Data:</strong> User Profile</p>+        <h2>Response</h2>     +    <ul>+          <li>User Profile</li>+        </ul>+         <p>The server responds with some HTML.</p>       </li>   <li>-        <p><strong>Log</strong></p>-    -        <p><strong>Data:</strong> Page Navigation</p>+        <h2>Log</h2>     +    <ul>+          <li>Page Navigation</li>+        </ul>+         <p>The Google Analytics plugin sends navigation<br/>data to Google.</p>       </li> </ol>  <h2>Threats</h2> -<p><p>No particular threats at this point.</p><p>It's <b>extremely</b> safe.</p></p>+<ul>+<li><code>csrf</code></li>+<li><code>mitm</code></li>+</ul>  </body> </html>

binary file changed (20935 → 22543 bytes)

@@ -1,11 +1,12 @@ module DataFlow.Attributes where  import qualified Data.Map as M+import Data.Functor ((<$>))  import DataFlow.Core  getTitleOrBlank :: Attributes -> String-getTitleOrBlank = M.findWithDefault "" "title"+getTitleOrBlank = show . M.findWithDefault (String "") "title"  getTitle :: Attributes -> Maybe String-getTitle = M.lookup "title"+getTitle a = show <$> M.lookup "title" a

@@ -1,5 +1,6 @@ module DataFlow.Core (   ID,+  Value(..),   Attributes,   Diagram(..),   RootNode(..),@@ -12,8 +13,18 @@ -- | An identifier corresponding to those in Graphviz. type ID = String -type Attributes = M.Map String String+data Value = String String+           | Array [Value]+           deriving (Eq) +instance Show Value where+  show (String s) = s+  show (Array vs) = show vs++-- | Attribute key-value pairs can be declared in diagrams, nodes, boundaries+-- | and flows.+type Attributes = M.Map String Value+ -- | The top level diagram. data Diagram = Diagram Attributes [RootNode] [Flow]                deriving (Eq, Show)@@ -23,7 +34,7 @@               -- | A top level Node.               Node Node               -- | Surrounds other non-root nodes, denoting a boundary.-              | TrustBoundary Attributes [Node]+              | TrustBoundary ID Attributes [Node]               deriving (Eq, Show)  data Node =

@@ -10,27 +10,17 @@ import DataFlow.Graphviz import DataFlow.Graphviz.EdgeNormalization -data DFDState = DFDState { step :: Int, clusterID :: Int }+type DFDState = Int type DFD v = State DFDState v  incrStep :: DFD ()-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)+incrStep = modify (+ 1)  -- | Get the next \"step\" number (the order of flow arrows in the diagram). nextStep :: DFD Int nextStep = do   incrStep-  liftM step get--nextClusterID :: DFD Int-nextClusterID = do-  incrClusterID-  liftM clusterID get+  get  inQuotes :: String -> String inQuotes s = "\"" ++ s ++ "\""@@ -92,16 +82,26 @@ 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 ++ "<br/>" ++ small d-                (Just op, Nothing) -> bold op-                (Nothing, Just d) -> small d-                _ -> ""++        asRows :: C.Value -> [String]+        asRows (C.String s) = lines s+        asRows (C.Array vs) = concatMap asRows vs++        rowsToTable :: [String] -> String+        rowsToTable rows =+          printf "<table border=\"0\" cellborder=\"0\" cellpadding=\"2\">%s</table>" r+          where r = concatMap (printf "<tr><td>%s</td></tr>") rows :: String++        rows = case (M.lookup "operation" attrs, M.lookup "data" attrs) of+                (Just op, Just d) -> (stepStr ++ bold (show op)) : map small (asRows d)+                (Just op, Nothing) -> [stepStr ++ bold (show op)]+                (Nothing, Just d) -> stepStr : map small (asRows d)+                _ -> []     return [         EdgeStmt (EdgeExpr (IDOperand (NodeID i1 Nothing))                           Arrow                           (IDOperand (NodeID i2 Nothing))) [-          label $ stepStr ++ text+          label $ rowsToTable rows         ]       ] @@ -109,10 +109,9 @@ convertFlows = liftM concat . mapM convertFlow  convertRootNode :: C.RootNode -> DFD StmtList-convertRootNode (C.TrustBoundary attrs nodes) = do+convertRootNode (C.TrustBoundary id' attrs nodes) = do   nodeStmts <- convertNodes nodes-  id' <- nextClusterID-  let sgId = "cluster_" ++ show id'+  let sgId = "cluster_" ++ id'       defaultSgAttrs = [           Attr "fontsize" "10",           Attr "fontcolor" "grey35",@@ -158,12 +157,12 @@   f <- convertFlows flows   return $ case M.lookup "title" attrs of               Just title ->-                let lbl = EqualsStmt "label" (inAngleBrackets $ bold title)+                let lbl = EqualsStmt "label" (inAngleBrackets $ show title)                     stmts = lbl : defaultGraphStmts ++ n ++ f-                in normalize $ Digraph (inQuotes title) stmts+                in normalize $ Digraph (inQuotes $ show title) stmts               Nothing ->                 normalize $ Digraph "Untitled" $ defaultGraphStmts ++ n ++ f  asDFD :: C.Diagram -> Graph-asDFD d = evalState (convertDiagram d) DFDState { step = 0, clusterID = 0 }+asDFD d = evalState (convertDiagram d) 0 

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module DataFlow.Hastache.Renderer (renderTemplate) where +import Control.Monad import Data.List.Utils import qualified Data.Map as M import qualified Data.Text as T@@ -22,32 +23,41 @@     defaults "markdown" = MuLambda markdownAttr     defaults "html_linebreaks" = MuLambda htmlLinebreaksAttr     defaults key = case M.lookup key attrs of-                    (Just v) -> MuVariable v+                    (Just v) -> mkValue v                     _ -> MuNothing +    mkValue :: Value -> MuType IO+    mkValue (String s) = MuVariable s+    mkValue (Array vs) =+      MuList $ map (mkStrContext . mkArrayContext) vs+      where mkArrayContext v "value" = mkValue v+            mkArrayContext 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+        (Just (String 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" "<br/>" s+        (Just (String s)) -> replace "\n" "<br/>" s         _ -> "" -mkFlowContext :: Flow -> MuContext IO-mkFlowContext (Flow _ _ attrs) = mkContextWithDefaults attrs (const MuNothing)+mkFlowContext :: Flow -> Int -> MuContext IO+mkFlowContext (Flow _ _ attrs) n = mkContextWithDefaults attrs ctx+  where ctx "number" = MuVariable $ show n+        ctx _ = 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 "flows" = MuList $ zipWith mkFlowContext flows [1..]   ctx _ = MuNothing  renderTemplate :: String -> FilePath -> Diagram -> IO TL.Text

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module DataFlow.JSONGraphFormat (+  Val(..),   Metadata(),   Document(..),   Graph(..),@@ -12,8 +13,15 @@ import qualified Data.Map         as M import           Data.Vector      (fromList) -type Metadata = M.Map String String+data Val = Str String+         | Arr [Val] +instance ToJSON Val where+  toJSON (Str s) = toJSON s+  toJSON (Arr vs) = toJSON vs++type Metadata = M.Map String Val+ data Document = SingleGraph { graph :: Graph }               | MultiGraph { graphs :: [Graph] } @@ -22,7 +30,7 @@       "graph" .= toJSON g     ]   toJSON (MultiGraph gs) = object [-      "graphs" .= (Array $ fromList $ map toJSON gs)+      "graphs" .= toJSON gs     ]  data Graph = Graph { nodes    :: [Node]@@ -34,8 +42,8 @@ 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),+      "nodes" .= toJSON nodes,+      "edges" .= toJSON edges,       "metadata" .= toJSON metadata     ] 

@@ -1,46 +1,62 @@ module DataFlow.JSONGraphFormat.Renderer (convertDiagram, renderJSONGraph) where -import           Data.Aeson+import qualified Data.Aeson               as A import           Data.ByteString.Lazy     (ByteString)+import           Data.Text (pack, unpack) import qualified Data.Map                 as M+import qualified Data.Vector              as V  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)+getTitle :: JG.Metadata -> Maybe String+getTitle m =  do+  v <- M.lookup "title" m+  case v of+    (JG.Str s) -> Just s+    _ -> Nothing +convertValue :: Value -> JG.Val+convertValue (String s) = JG.Str s+convertValue (Array vs) = JG.Arr (map convertValue vs)++convertAttrs :: Attributes -> M.Map String JG.Val+convertAttrs = M.map convertValue++withLabelAndMetadataFrom :: (Maybe String -> JG.Metadata -> v) -> JG.Metadata -> v+f `withLabelAndMetadataFrom` metadata = f (getTitle metadata) (M.delete "title" metadata)+ addType :: String -> JG.Metadata -> JG.Metadata-addType = M.insert "type"+addType s = M.insert "type" (JG.Str s)  addBoundary :: Maybe String -> JG.Metadata -> JG.Metadata-addBoundary (Just b) m = M.insert "trust-boundary" b m+addBoundary (Just b) m = M.insert "trust-boundary" (JG.Str 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)+  JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "io" $ convertAttrs attrs) convertNode b (Function id attrs) =-  JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "function" attrs)+  JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "function" $ convertAttrs attrs) convertNode b (Database id attrs) =-  JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "database" attrs)+  JG.Node id `withLabelAndMetadataFrom` addBoundary b (addType "database" $ convertAttrs 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+convertRootNode (TrustBoundary id' attrs nodes) =+  map (convertNode (Just id')) nodes  convertFlow :: Flow -> JG.Edge convertFlow (Flow source target attrs) =-  JG.Edge source target `withLabelAndMetadataFrom` attrs+  JG.Edge source target `withLabelAndMetadataFrom` convertAttrs 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+      graph = JG.Graph nodes edges `withLabelAndMetadataFrom` convertAttrs attrs   in JG.SingleGraph graph  renderJSONGraph :: Diagram -> ByteString-renderJSONGraph = encode . convertDiagram+renderJSONGraph = A.encode . convertDiagram

@@ -1,8 +1,12 @@-module DataFlow.Reader where+module DataFlow.Reader (+    document,+    readDiagram,+    readDiagramFile+) where  import Control.Monad import Data.Functor ((<$>))-import Control.Applicative ((<*>))+import Control.Applicative ((<*>), (<*), (*>)) import Data.Char import Data.List import qualified Data.Map as M@@ -10,46 +14,73 @@  import DataFlow.Core +commentsAndSpace :: Parser ()+commentsAndSpace = do+  spaces+  skipMany comment+  spaces+  where+  comment = do+    _ <- string "/*"+    _ <- manyTill anyChar (try $ string "*/")+    return ()+ identifier :: Parser ID identifier = do   first <- letter   rest <-  many (letter <|> digit <|> char '_')   return $ first : rest -str :: Parser String+str :: Parser Value str = do   -- TODO: Handle escaped characters.   _ <- char '"'   s <- many (noneOf "\"\r\n")   _ <- char '"'-  return s+  return $ String s -textBlock :: Parser String+textBlock :: Parser Value textBlock = do   _ <- char '`'   s <- anyToken `manyTill` try (char '`')-  return $ intercalate "\n" $ map (dropWhile isSpace) $ lines s+  return $ String $ intercalate "\n" $ map (dropWhile isSpace) $ lines s -inBraces :: Parser t -> Parser t-inBraces inside = do-  spaces-  _ <- char '{'-  spaces-  c <- inside-  spaces-  _ <- char '}'-  spaces+inside :: Parser x -> Parser y -> Parser t -> Parser t+inside before after p = do+  commentsAndSpace+  _ <- before+  commentsAndSpace+  c <- p+  commentsAndSpace+  _ <- after+  commentsAndSpace   return c -attr :: Parser (String, String)+inBraces :: Parser t -> Parser t+inBraces = inside (char '{') (char '}')++inSquareBrackets :: Parser t -> Parser t+inSquareBrackets = inside (char '[') (char ']')++array :: Parser Value+array =+  let sep = do _ <- char ','+               commentsAndSpace+  in Array <$>+    inSquareBrackets (value `sepBy` sep) <* commentsAndSpace++value :: Parser Value+value = try textBlock <|> try str <|> array++attr :: Parser (String, Value) attr = do   key <- identifier   skipMany1 $ char ' '   _ <- char '='   skipMany1 $ char ' '-  value <- try textBlock <|> str-  spaces-  return (key, value)+  v <- value+  commentsAndSpace+  return (key, v)  attrs :: Parser Attributes attrs = liftM M.fromList $ many (try attr)@@ -104,25 +135,29 @@   n <- try function        <|> try database        <|> io-  spaces+  commentsAndSpace   return n  boundary :: Parser RootNode boundary = do   _ <- string "boundary"-  inBraces (TrustBoundary <$> attrs <*> many node)+  skipMany1 space+  id' <- identifier+  inBraces (TrustBoundary id' <$> attrs <*> many node)  rootNode :: Parser RootNode rootNode = try (Node <$> node)            <|> boundary  diagram :: Parser Diagram-diagram = do-  _ <- string "diagram"-  inBraces (Diagram <$> attrs <*> many (try rootNode) <*> many flow)+diagram =+  string "diagram" *> inBraces (Diagram <$> attrs <*> many (try rootNode) <*> many flow) +document :: Parser Diagram+document = commentsAndSpace *> diagram <* commentsAndSpace+ readDiagram :: String -> String -> Either ParseError Diagram-readDiagram = parse diagram+readDiagram = parse document  readDiagramFile :: FilePath -> IO (Either ParseError Diagram)-readDiagramFile = parseFromFile diagram+readDiagramFile = parseFromFile document

@@ -22,6 +22,13 @@   join "\\n" $ map italic' $ split "\\n" s   where italic' = printf "<i>%s</i>" +showValue :: C.Value -> String+showValue (C.String s) = convertNewline s+showValue (C.Array vs) = join "\\n" $ map showValue vs++blank :: C.Value+blank = C.String ""+ convertNode :: C.Node -> Stmt convertNode (C.InputOutput id' attrs) =   Entity id' $ convertNewline $ getTitleOrBlank attrs@@ -32,8 +39,8 @@  convertFlow :: C.Flow -> Stmt convertFlow (C.Flow i1 i2 attrs) =-  let p = (convertNewline (bold $ M.findWithDefault "" "operation" attrs),-           italic $ convertNewline (M.findWithDefault "" "data" attrs))+  let p = (bold $ showValue $ M.findWithDefault blank "operation" attrs,+           italic $ showValue $ M.findWithDefault blank "data" attrs)       s = case p of             ("", "") -> ""             ("", d) -> d@@ -42,8 +49,9 @@   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.TrustBoundary id' attrs nodes) =+  let title = showValue $ M.findWithDefault (C.String id') "title" attrs+  in Box title (map convertNode nodes) convertRootNode (C.Node n) = convertNode n  defaultSkinParams :: [Stmt]@@ -89,6 +97,6 @@  asSequenceDiagram :: C.Diagram -> Diagram asSequenceDiagram (C.Diagram _ rootNodes flows) =-  SequenceDiagram $ defaultSkinParams -                    ++ map convertRootNode rootNodes +  SequenceDiagram $ defaultSkinParams+                    ++ map convertRootNode rootNodes                     ++ map convertFlow flows

@@ -0,0 +1,55 @@+module DataFlow.Validation (+    ValidationError(..),+    validate+) where++import Data.Set (Set, member, insert, empty)+import Text.Printf++import DataFlow.Core++data ValidationError = UnknownID ID+                     | DuplicateDeclaration ID+                     deriving (Eq)++instance Show ValidationError where+  show (UnknownID i) = printf "Unknown ID: %s" i+  show (DuplicateDeclaration i) = printf "Duplicate declaration of ID: %s" i++getNodeIDs :: Diagram -> [ID]+getNodeIDs (Diagram _ nodes _) = concatMap getRootNodeId nodes+  where getId (InputOutput i _) = [i]+        getId (Function i _) = [i]+        getId (Database i _) = [i]+        getRootNodeId (Node node) = getId node+        getRootNodeId (TrustBoundary _ _ nodes) = concatMap getId nodes++getBoundaryIDs :: Diagram -> [ID]+getBoundaryIDs (Diagram _ nodes _) = concatMap getRootNodeId nodes+  where getRootNodeId (TrustBoundary id _ _) = [id]+        getRootNodeId _ = []++validateDuplicateIDs :: [ID] -> Either [ValidationError] (Set ID)+validateDuplicateIDs ids =+  case foldl iter (empty, []) ids of+    (seen, []) -> Right seen+    (_, errors) -> Left errors+  where iter (seen, errors) i = if i `member` seen+                                  then (seen, errors ++ [DuplicateDeclaration i])+                                  else (insert i seen, errors)++validateFlowIDs :: Diagram -> Set ID -> Either [ValidationError] ()+validateFlowIDs (Diagram _ _ flows) ids =+  case foldl iter [] flows of+    [] -> Right ()+    errors -> Left errors+  where idError i = if i `member` ids then [] else [UnknownID i]+        iter errors (Flow source target _) =+          errors ++ idError source ++ idError target++validate :: Diagram -> Either [ValidationError] Diagram+validate diagram = do+  nodeIDs <- validateDuplicateIDs (getNodeIDs diagram)+  validateDuplicateIDs (getBoundaryIDs diagram)+  validateFlowIDs diagram nodeIDs+  return diagram