jespresso (empty) → 0.9
raw patch · 17 files changed
+827/−0 lines, 17 filesdep +HTTPdep +arrowsdep +basesetup-changed
Dependencies added: HTTP, arrows, base, bytestring, cmdargs, data-default-class, directory, filepath, http-encodings, hxt, hxt-tagsoup, jespresso, language-ecmascript, network, random, tasty, tasty-golden, transformers
Files
- LICENSE +31/−0
- Main.hs +59/−0
- Setup.hs +2/−0
- jespresso.cabal +70/−0
- src/Network/Browser/Simple.hs +25/−0
- src/Text/Html/Consolidate.hs +378/−0
- test-data/cases/complex1.html +70/−0
- test-data/cases/form1.html +6/−0
- test-data/cases/iframe1.html +8/−0
- test-data/cases/scriptSimple1.html +13/−0
- test-data/cases/trivial.html +6/−0
- test-data/expects/complex1.html +68/−0
- test-data/expects/form1.html +6/−0
- test-data/expects/iframe1.html +9/−0
- test-data/expects/scriptSimple1.html +13/−0
- test-data/expects/trivial.html +7/−0
- test/UnitTest.hs +56/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2012-2013 Stevens Institute of Technology++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Stevens Institute of Technology nor the+ names of the authors and other contributors may be used to+ endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,59 @@+module Main where++import Text.Html.Consolidate+import System.Console.CmdArgs.Explicit+import System.IO+import Network.URI+import Network.Browser+import Network.Browser.Simple++-- | The entry point to the `jespresso` program. Can be run in two+-- modes:+-- * extraction; `jespresso [-e] [<uri>]`. Takes text (HTML) via stdin+-- and outputs all the JavaScript in it (including externally+-- referenced) via stdout. If an (optional) url is supplied, the HTML+-- is downloaded from that URL instead of reading it from the stdin.+-- * normalization: `jespresso -n [<uri>]`. Transforms the HTML and+-- JavaScript into an equivalent one so that all the JavaScript is+-- inlined and in a single <script> tag. If an (optional) url is+-- supplied, the HTML is downloaded from that URL instead of reading+-- it from the stdin.++main :: IO Int+main = do args <- processArgs arguments + (input, cookies) <- case muri args of+ Just uri -> download uri []+ Nothing -> getContents >>= \c -> return (c, [])+ output <- case pmode args of+ Extraction -> extract input (muri args)+ Consolidation -> consolidate input (muri args)+ putStr output+ return 1++arguments :: Mode Parameters+arguments = (modeEmpty defaultArgs) + {modeNames = ["jespresso"]+ ,modeHelp = ""+ ,modeArgs = ([flagArg addURI "URI"], Nothing)+ ,modeGroupFlags = + toGroup+ [flagNone ["e", "extract"] addExtract extractHelp+ ,flagNone ["n", "normalize"] addNormalize normalizeHelp]}+ where defaultArgs = Parameters {pmode = Extraction+ ,muri = Nothing}+ addURI u params = case parseURI u of+ Nothing -> Left "Invalid URI"+ Just uri -> Right $ params {muri = Just uri}+ addExtract params = params {pmode = Extraction}+ addNormalize params = params {pmode = Consolidation}+ extractHelp = "Extract JavaScript from the supplied HTML and \+ \print to stdout"+ normalizeHelp = "Transform HTML (with JavaScript in it) into an \+ \equivalent one so that all the JavaScript is inlined \+ \and in a single <script> tag."++data Parameters = Parameters {pmode :: ProgramMode+ ,muri :: Maybe URI}+ deriving (Show)+data ProgramMode = Extraction | Consolidation+ deriving (Show)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jespresso.cabal view
@@ -0,0 +1,70 @@+-- Initial jespresso.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: jespresso+version: 0.9+synopsis: Extract all JavaScript from an HTML page and consolidate it in one script.+description: Allows extraction and consolidation of JavaScript code in an HTML page so that it behaves like the original. Consolidation is a process of transforming an HTML page into an equivalent, but containing JavaScript code only in one inlined script tag.+license: BSD3+license-file: LICENSE+author: Andrey Chudnov+maintainer: Andrey Chudnov <oss@chudnov.com>+Homepage: http://github.com/achudnov/jespresso+Bug-reports: http://github.com/achudnov/jespresso/issues+copyright: (c) 2012-2013 Stevens Institute of Technology+category: Web+stability: Experimental+tested-with: GHC==7.6.3+build-type: Simple+cabal-version: >=1.10+extra-source-files: test-data/cases/*.html, test-data/expects/*.html++Source-repository head+ type: git+ location: git://github.com/achudnov/jespresso.git++Source-repository this+ type: git+ location: git://github.com/achudnov/jespresso.git+ tag: 0.9++library+ build-depends: base >=4.2.0 && < 5+ ,hxt >= 9.2.0 && < 10+ ,hxt-tagsoup >= 9.1.1 && < 10+ ,arrows >= 0.4 && < 0.5+ ,HTTP >= 4000.2.0 && < 5000+ ,language-ecmascript >= 0.15 && < 1.0+ ,random >= 1 && < 2+ ,bytestring >= 0.9 && < 0.11+ ,http-encodings >= 0.9.1 && < 1.0+ ,network >= 2.4 && < 2.5+ ,data-default-class >= 0.0.1 && < 0.1+ exposed-modules: Text.Html.Consolidate+ Network.Browser.Simple+ hs-source-dirs: src+ default-language: Haskell2010++executable jespresso+ main-is: Main.hs+ build-depends: base >=4.2.0 && < 5+ ,jespresso+ ,cmdargs >= 0.9 && < 0.11+ ,HTTP >= 4000.2.0 && < 5000+ ,network >= 2.4 && < 2.5+ default-language: Haskell2010++Test-Suite unittest+ Hs-Source-Dirs: test+ Type: exitcode-stdio-1.0+ Main-Is: UnitTest.hs+ Build-Depends: base >= 4 && < 5+ ,jespresso+ ,tasty >= 0.4 && < 0.5+ ,tasty-golden >= 2.2 && < 2.3+ ,directory >= 1.2 && < 1.3+ ,filepath >= 1.1 && < 1.4+ ,hxt >= 9.2.0 && < 10+ ,arrows >= 0.4 && < 0.5+ ,transformers >= 0.3 && < 0.4+ Default-Language: Haskell2010
+ src/Network/Browser/Simple.hs view
@@ -0,0 +1,25 @@+-- | A wrapper around Network.HTTP to present a simpler interface for+-- requesting pages via HTTP+module Network.Browser.Simple (download) where++import Network.URI+import Network.HTTP+import Network.Browser+import Network.HTTP.Encoding+import Data.ByteString.Lazy++-- | Requests a web page specified by the URI, including optional+-- cookies. Returns the contents of the page as a @String@ and new+-- cookies. Follows redirects, decodes the response body, if+-- possible. Can fail if decoding is impossible.+download :: URI -> [Cookie] -> IO (String, [Cookie])+download uri cookies = + browse $ do setAllowRedirects True+ setUserAgent "Mozilla/5.0 (compatible; jespresso/1.0)"+ setCookies cookies+ (_, rsp) <- request (defaultGETRequest_ uri :: Request ByteString)+ cks <- getCookies+ return (rsp, cks)+ >>= \(rsp, cks) -> case decodeBody rsp of+ Left msg -> fail $ show msg+ Right res -> return (decodedBody res, cks)
+ src/Text/Html/Consolidate.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Arrows #-}+-- | Implements extraction and consolidation of JavaScript code in an+-- HTML page.+module Text.Html.Consolidate (-- * Simple API+ consolidate+ ,extract+ -- * Advanced arrow-based API+ ,TArr + ,consolidateArr+ ,extractJSArr+ ,initialConsState+ ,insertJSArr+ ,parseHTML+ ,renderHTML+ ) where++import Text.XML.HXT.Core hiding (swap)+import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow+import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.TagSoup+import Language.ECMAScript3.Syntax+import Language.ECMAScript3.Syntax.Annotations+import Language.ECMAScript3.PrettyPrint+import Language.ECMAScript3.Parser+import Data.List (isInfixOf)+import Data.Default.Class+import Network.HTTP+import Network.Browser (Cookie)+import Network.Browser.Simple+import Network.URI+import Network.HTTP.Encoding+import Data.ByteString.Lazy (ByteString)+import System.Random+import Data.Char+import Data.Maybe (isJust, fromJust, maybeToList)+import Control.Monad hiding (when)++data ConsState = ConsState Bool -- Ignore errors?+ (Maybe URI) -- Base URI of the web page,+ -- for resolving relative URI's+ [Cookie] -- Cookies to include with all+ -- HTTP requests+ [Statement ()]++-- | A constructor function for making an initial consolidation state+-- (needed for running the arrows in the advanced API)+initialConsState :: Bool -- ^ Whether to ignore errors (parse errors,+ -- resource not found etc.)+ -> Maybe URI -- ^ base URI+ -> [Cookie] -- ^ Cookies+ -> ConsState+initialConsState grace base cookies = ConsState grace base cookies []++-- | Our XML transformation arrow type+type TArr a b = IOStateArrow ConsState a b++-- | A wrapper around the hxt parser with commonly used arguments+parseHTML :: String -> Maybe URI -> TArr a XmlTree+parseHTML s mbase_uri = + let config = map (withDefaultBaseURI . show) (maybeToList mbase_uri)+ ++[withParseHTML yes+ ,withTagSoup+ ,withValidate no+ ,withSubstDTDEntities no+ ,withSubstHTMLEntities yes+ ,withCanonicalize no+ ,withOutputHTML]+ in readString config s++-- | A wrapper around hxt to pretty print html out of the arrow+renderHTML :: ConsState -> TArr XmlTree XmlTree -> IO String+renderHTML ns a = + let state = initialState ns+ in liftM head $ runXIOState state ((single a) >>> writeDocumentToString [withOutputHTML, withOutputEncoding utf8])++-- | Takes an HTML page source as a string and an optional base URI+-- (for resolving relative URI's) and produces an HTML page with all+-- the scripts consolidated in one inline script element.+consolidate :: String -> Maybe URI -> IO String+consolidate s mbase_uri = + renderHTML (initialConsState True mbase_uri []) $ + parseHTML s mbase_uri >>> consolidateArr++-- | Main normalization arrow. Factored into extractJS and insertJS to+-- allow custom transformation of JavaScript inbetween.+consolidateArr :: TArr XmlTree XmlTree+consolidateArr = extractJSArr >>> insertJSArr++-- | Extacts and pretty-print all the JavaScript code in the given+-- HTML page source as a single program. Takes an optional base URI+-- for resolving relative URI's.+extract :: String -> Maybe URI -> IO String+extract s mbase_uri =+ let state = initialState $ initialConsState True mbase_uri [] in+ do [(_, js)] <- runXIOState state $ single $ + parseHTML s mbase_uri >>> extractJSArr+ return js++-- | Extracts all the JavaScript from HTML. There shouldn't be any+-- JavaScript in the resulting XmlTree+extractJSArr :: TArr XmlTree (XmlTree, String)+extractJSArr =+ ((choiceA [isAJavaScript :-> ifA (hasAttr "src") extractExternalScript+ extractInlineScript+ ,(isElem >>> hasOneOfNames src_tags >>> hasOneOfAttrs src_attrs) :-> extractURLProp+ ,(isElem >>> hasOneOfAttrs event_handlers) :-> extractEventHandler+ ,this :-> this+ ])+ `processTopDownUntilAndWhenMatches` isFrame)+ >>>returnScript+ where returnScript = (returnA &&& getUserState)+ >>> second (arr (\s -> let ConsState _ _ _ stmts = s + in show $ prettyPrint stmts))+ isFrame = isElem >>> (hasName "frame" <+> hasName "iframe")+ hasOneOfNames tagNames = (getName >>> isA (`elem` tagNames)) `guards` this+ hasOneOfAttrs attrNames = (getAttrl >>> hasOneOfNames attrNames) `guards` this+ -- Elements and properties that might contain a 'javascript:' url + -- IMG.SRC, A.HREF, FORM.ACTION, FRAME.SRC, IFRAME.SRC, LINK.HREF+ src_tags = ["img", "a", "form", "frame", "iframe", "link"]+ src_attrs = ["src", "href", "action"]+ event_handlers = ["onabort", "onblur", "onclick", "oncompositionstart"+ ,"oncompositionupdate", "oncompositionend", "ondblclick"+ ,"onerror", "onfocus", "onfocusin", "onfocusout"+ ,"onkeydown", "onkeypress", "onkeyup", "onload"+ ,"onmousedown", "onmouseenter", "onmouseleave"+ ,"onmousemove", "onmouseout", "onmouseover"+ ,"onmouseup", "onreset", "onresize","onscroll"+ ,"onselect", "onsubmit", "ontextinput", "onunload"+ , "onwheel"]++-- | Like Control.Arrow.ArrowTree, but instead has a separate arrow+-- that serves as a predicate signalling that this subtree shouldn't+-- be transformed any further; 'processTopDownUntilMatches transformer+-- predicate'. Almost dual of 'processBottomUpWhenNot', but transforms+-- the node that matches the predicate as well (but doesn't look+-- inside that node).+processTopDownUntilAndWhenMatches :: (ArrowTree a, Tree t)+ => a (t b) (t b) -- ^ the transformer arrow+ -> a (t b) (t b) -- ^ the predicate arrow+ -> a (t b) (t b)+processTopDownUntilAndWhenMatches t p =+ t >>> (processChildren (processTopDownUntilAndWhenMatches t p) `whenNot` p)+ -- ifA p (t >>> processChildren (processTopDownUntilAndWhenMatches t p)) returnA+ +-- | Inserts JavaScript at the end of the HTML body.+insertJSArr :: TArr (XmlTree, String) XmlTree+insertJSArr = (swap ^<< (second scriptElement)) >>>+ arr2A (\scr -> processTopDown $ changeChildren (++ [scr]) `when`+ hasName "body")+ +-- extractors+-- | Extracts the contents of inline scripts+extractInlineScript :: TArr XmlTree XmlTree+extractInlineScript = + (firstChild >>> + getText >>> + parseJS >>> + arr removeAnnotations >>> + appendScript >>>+ cmt "Removed Inline Script") ++-- | Extracts the contents of externally references scripts+extractExternalScript :: TArr XmlTree XmlTree+extractExternalScript = + ((getAttrValue "src" >>>+ (downloadArr >>>+ parseJS >>>+ arr removeAnnotations >>> + appendScript) + &&&+ (arr ("Removed External Script: " ++) >>>+ mkCmt)) >>>+ arr snd)+ +-- |Downloads the content, considering the input as a URL; performs+-- decoding automatically.+downloadArr :: TArr String String+downloadArr = + (returnA &&& arr parseURIReference) >>> + arrIO (\(url, muri) -> + failIfNothing ("download: error parsing a URI: " ++ url) muri) >>>+ consolidateURI >>>+ (getUserState &&& returnA) >>>+ arrIO (\(ConsState _ _ cookies _, uri) -> liftM fst (download uri cookies))++ where failIfNothing :: String -> Maybe a -> IO a+ failIfNothing message Nothing = fail message+ failIfNothing _ (Just x) = return x+ -- RFC 3986, section 4.1: if the URI-reference's prefix does+ -- not match the syntax of a scheme followed by its colon+ -- separator, then the URI reference is a relative reference.+ isURIRelative :: URI -> Bool+ isURIRelative = null . uriScheme+ consolidateURI :: TArr URI URI+ consolidateURI = + (getUserState &&& returnA) >>>+ arrIO (\(ConsState _ mbaseURI _ _, uri) ->+ return $ if isURIRelative uri && isJust mbaseURI+ then uri `relativeTo` fromJust mbaseURI+ else uri)+ +-- Removes the URL containing properties from elements and adds a+-- JavaScript assignment instead.+extractURLProp :: TArr XmlTree XmlTree+extractURLProp = + -- Elements and properties that might contain a 'javascript:' url + -- IMG.SRC, A.HREF, FORM.ACTION, FRAME.SRC, IFRAME.SRC, LINK.HREF+ -- isElem >>>+ -- selectTags ["img", "a", "form", "frame", "iframe", "link"] >>>+ addIdIfNotPresent >>>+ (((selectAttrValues ["src", "href", "action"] + &&& selectId) >>>+ arr (\((url, attrName), id) -> + Script () [ExprStmt () $ AssignExpr () OpAssign + (LDot () (CallExpr ()+ (DotRef () (VarRef () (Id () "document")) (Id () "getElementById"))+ [StringLit () id]) attrName) (StringLit () url)]) >>>+ appendScript) &&& + removeAttributes ["src", "href", "action"]) >>>+ arr snd+ +-- Removes the event handlers from HTML tags and converts them to+-- JavaScript assignments+extractEventHandler :: TArr XmlTree XmlTree+extractEventHandler = + -- Names of HTML tag attributes that are event handler declarations:+ let attrNames = ["onabort", "onblur", "onclick", "oncompositionstart",+ "oncompositionupdate", "oncompositionend", "ondblclick", + "onerror", "onfocus", "onfocusin", "onfocusout", "onkeydown",+ "onkeypress", "onkeyup", "onload", "onmousedown",+ "onmouseenter", "onmouseleave", "onmousemove", "onmouseout", + "onmouseover", "onmouseup", "onreset", "onresize","onscroll",+ "onselect", "onsubmit", "ontextinput", "onunload", "onwheel"]+ -- in isElem >>>+ -- hasAnyAttrs attrNames >>>+ in addIdIfNotPresent >>>+ (((selectAttrValues attrNames &&& selectId) >>>+ arr (\((handler, attrName), id) ->+ Script () [ExprStmt () $ AssignExpr () OpAssign + (LDot () (CallExpr ()+ (DotRef () (VarRef () (Id () "document")) (Id () "getElementById"))+ [StringLit () id]) attrName) (StringLit () handler)])+ >>> appendScript) &&&+ removeAttributes attrNames) >>>+ arr snd++parseJS :: TArr String (JavaScript SourcePos)+parseJS = arr (parse program "") >>> eitherToFailure++-- Arrow tools+-- | Failure reporting arrow constructor+arrowFail :: ArrowIO ar => String -> ar b c+arrowFail = arrIO . fail++isStrict :: TArr a Bool+isStrict = getUserState >>> arr (\s -> let ConsState strict _ _ _ = s in strict)++-- | If in strict mode, fails with the message given; otherwise,+-- behaves like an identity arrow+failIfStrict :: String -> TArr a a+failIfStrict msg = + proc a -> do is <- isStrict -< ()+ if is then arrowFail msg -< () else returnA -< a++eitherToFailure :: (Show err, Default a) => TArr (Either err a) a+eitherToFailure = (isStrict &&& returnA) >>> arrIO f+ where f (False, Left err) = return def+ f (True, Left err) = fail $ show err+ f (_ , Right x) = return x++maybeToFailure :: (Default a) => Maybe String -> TArr (Maybe a) a+maybeToFailure message = (isStrict &&& returnA) >>> arrIO f+ where f (False, Nothing) = return def+ f (True , Nothing) = + case message of+ Nothing -> fail "Unexpected maybe in strict mode"+ Just msg -> fail msg+ f (_ , Just x) = return x++appendStatements :: TArr [Statement ()] ()+appendStatements = (getUserState &&& returnA) >>>+ arr (\(state, addScript) -> + let ConsState grace baseURI cookies script = state in+ ConsState grace baseURI cookies (script++addScript)) >>>+ setUserState >>> arr (const ())++appendScript :: TArr (JavaScript ()) ()+appendScript = arr (\s -> let Script _ stmts = s in stmts) >>> appendStatements+ +-- constructors+-- | Constructs a new JavaScript element+scriptElement :: ArrowXml ar => ar String XmlTree+scriptElement = (mkElement (mkName "script") (sattr "type" "text/javascript")) $< arr txt++-- Selectors+-- | A selector for SCRIPT tags with JavaScript or empty type+isAJavaScript :: ArrowXml ar => ar XmlTree XmlTree+isAJavaScript = + isElem >>> hasName "script" >>>+ (((hasAttr "language" >>> hasAttrValue "language" (isInfixOf "javascript")) <+>+ (hasAttr "type" >>> hasAttrValue "type" (isInfixOf "javascript"))) `orElse`+ returnA)+ +-- | Selects the first child of a node+firstChild :: (ArrowTree a, Tree t) => a (t b) (t b)+firstChild = single getChildren+ +-- | Selects the last child fo a node+lastChild :: (ArrowTree a, Tree t) => a (t b) (t b)+lastChild = getChildren >>. (take 1 . reverse)++-- | Selects the <html> tag+html :: ArrowXml a => a XmlTree XmlTree+html = deep $ hasName "html"++-- | Selects <body> tag+body :: ArrowXml a => a XmlTree XmlTree+body = html /> hasName "body"+ --deep $ hasName "html" /> hasName "body"++selectTags :: ArrowXml a => [String] -> a XmlTree XmlTree+selectTags = foldl (\arr tag -> arr <+> hasName tag) zeroArrow++selectAttrValues :: ArrowXml a => [String] -> a XmlTree (String, String)+selectAttrValues = foldl f zeroArrow+ where f :: ArrowXml a => + a XmlTree (String, String) -> String -> a XmlTree (String, String)+ f a attr = a <+> (hasAttr attr >>> + (getAttrValue attr &&& arr (const attr)))+ +hasAnyAttrs :: ArrowXml a => [String] -> a XmlTree XmlTree+hasAnyAttrs = foldl f zeroArrow+ where f :: ArrowXml a => a XmlTree XmlTree -> String -> a XmlTree XmlTree+ f a attr = a <+> hasAttr attr+ +removeAttributes :: ArrowXml a => [String] -> a XmlTree XmlTree+removeAttributes = foldl f zeroArrow+ where f :: ArrowXml a => a XmlTree XmlTree -> String -> a XmlTree XmlTree+ f a attr = a >>> removeAttr attr+ ++addIdIfNotPresent :: TArr XmlTree XmlTree+addIdIfNotPresent = proc node -> do+ idval <- getAttrValue "id" -< node+ if null idval+ then replaceChildren repFun -< node+ else returnA -< node+ where repFun = replaceChildren (genIdA >>> mkText)+ `when` (isAttr >>> hasName "id")++-- | Selects the id of an element or adds a new one (and returns) if+-- it's not present+selectId :: TArr XmlTree String+selectId = isElem >>> getAttrValue "id"+ +genIdA :: ArrowIO ar => ar a String+genIdA = arrIO $ const genId++genId :: IO String+genId = do firstLetter <- genLetter+ return [firstLetter]+ length <- getStdRandom $ randomR (minIdLength-1, maxIdLength-1)+ restId <- mapM (const genLetter) [1..length] + return $ firstLetter:restId+ where minIdLength :: Int+ minIdLength = 16+ maxIdLength = 32+ +genLetter :: IO Char+genLetter = do letter <- getStdRandom $ randomR (capitalACode, capitalZCode)+ lettercase <- getStdRandom $ randomR (0,1)+ return $ chr $ letter + lettercase * (lowercaseACode-capitalACode)+ where capitalACode = 65+ capitalZCode = 90+ lowercaseACode = 97+ +swap (a,b) = (b,a)
+ test-data/cases/complex1.html view
@@ -0,0 +1,70 @@+<!DOCTYPE html>+<html>+ <head>+ <meta charset="UTF-8">+ <title>Merchant example</title>+ <script src="http://chudnov.com/research/jsinline/examples/mashups/payment/iframe/ulj.js"></script>+ </head>+ <body>+ <div id="order_summary">+ <h1>Your order summary</h1>+ <form id="cart_form" onsubmit="onCartUpdate()">+ <table id="cart">+ <thead>+ <tr>+ <th>Item</th>+ <th>Price</th>+ <th>Qty</th>+ </tr>+ </thead>+ <tbody>+ <tr>+ <td>A bar of foo</td>+ <td>5</td>+ <td><input type="text" value="1"></td>+ </tr>+ <tr>+ <td>Sprocket 13-pin</td>+ <td>7</td>+ <td><input type="text" value="1"></td>+ </tr>+ </tbody>+ </table>+ <input type="submit" value="Update total">+ </form>+ <script type="text/javascript">+ var key = 42;+ window.onmessage = function (e) {+ var confirmation;+ try {+ confirmation = JSON.parse(e.data);+ } catch (e) {+ alert("Received invalid confirmation from the payment service. Please try again");+ }+ if (confirmation) {+ /*if (confirmation.transaction_id * confirmation.amount * key == + confirmation.signature) {*/+ if (confirmation.signature == 42) {+ alert("Your order has been confirmed! Thank you!");+ } else alert("Received invalid confirmation from the payment service. Please try again");+ }+ }+ function onCartUpdate(e) {+ var total = 0;+ rows = document.getElementById("cart").tBodies[0].rows;+ for (var i = 0; i < rows.length; i++) {+ total += parseInt(rows[i].cells[1].firstChild.data)*+ parseInt(rows[i].cells[2].firstChild.value);+ }+ var w = document.getElementById("payment_frame").contentWindow;+ w.postMessage(total.toString(), "http://chudnov.com");+ if(e.preventDefault) e.preventDefault();+ e.returnValue=false;+ }, true);+ </script>+ </div>+ <iframe src="http://chudnov.com/research/jsinline/examples/mashups/payment/iframe/payment.html"+ id="payment_frame">+ </iframe>+ </body>+</html>
+ test-data/cases/form1.html view
@@ -0,0 +1,6 @@+<html>+ <body>+ <form>+ </form>+ </body>+</html>
+ test-data/cases/iframe1.html view
@@ -0,0 +1,8 @@+<html>+ <body>+ <div>+ <iframe>+ </iframe>+ </div>+ </body>+</html>
+ test-data/cases/scriptSimple1.html view
@@ -0,0 +1,13 @@+<!DOCTYPE html>+<html>+ <head>+ <meta charset="UTF-8">+ <title>MyTest</title>+ </head>+ <body>+ <script>+ foo(bar);+ </script>+ <span>Test</span>+ </body>+</html>
+ test-data/cases/trivial.html view
@@ -0,0 +1,6 @@+<html>+ <head>+ </head>+ <body>+ </body>+</html>
+ test-data/expects/complex1.html view
@@ -0,0 +1,68 @@+<html>+ <head>+ <meta charset="UTF-8"/>+ <title>Merchant example</title>+ <!--Removed External Script: http://chudnov.com/research/jsinline/examples/mashups/payment/iframe/ulj.js-->+ </head>+ <body>+ <div id="order_summary">+ <h1>Your order summary</h1>+ <form id="cart_form" onsubmit="onCartUpdate()">+ <table id="cart">+ <thead>+ <tr>+ <th>Item</th>+ <th>Price</th>+ <th>Qty</th>+ </tr>+ </thead>+ <tbody>+ <tr>+ <td>A bar of foo</td>+ <td>5</td>+ <td><input type="text" value="1"/></td>+ </tr>+ <tr>+ <td>Sprocket 13-pin</td>+ <td>7</td>+ <td><input type="text" value="1"/></td>+ </tr>+ </tbody>+ </table>+ <input type="submit" value="Update total"/>+ </form>+ <script type="text/javascript">+ var key = 42;+ window.onmessage = function (e) {+ var confirmation;+ try {+ confirmation = JSON.parse(e.data);+ } catch (e) {+ alert("Received invalid confirmation from the payment service. Please try again");+ }+ if (confirmation) {+ /*if (confirmation.transaction_id * confirmation.amount * key == + confirmation.signature) {*/+ if (confirmation.signature == 42) {+ alert("Your order has been confirmed! Thank you!");+ } else alert("Received invalid confirmation from the payment service. Please try again");+ }+ }+ function onCartUpdate(e) {+ var total = 0;+ rows = document.getElementById("cart").tBodies[0].rows;+ for (var i = 0; i < rows.length; i++) {+ total += parseInt(rows[i].cells[1].firstChild.data)*+ parseInt(rows[i].cells[2].firstChild.value);+ }+ var w = document.getElementById("payment_frame").contentWindow;+ w.postMessage(total.toString(), "http://chudnov.com");+ if(e.preventDefault) e.preventDefault();+ e.returnValue=false;+ }, true);+ </script>+ </div>+ <iframe id="payment_frame">+ </iframe>+ <script type="text/javascript"></script></body>+</html>
+ test-data/expects/form1.html view
@@ -0,0 +1,6 @@+<html>+ <body>+ <form>+ </form>+ <script type="text/javascript"></script></body>+</html>
+ test-data/expects/iframe1.html view
@@ -0,0 +1,9 @@+<html>+ <body>+ <div>+ <iframe>+ </iframe>+ </div>+ <script type="text/javascript"></script>+ </body>+</html>
+ test-data/expects/scriptSimple1.html view
@@ -0,0 +1,13 @@+<html>+ <head>+ <meta charset="UTF-8"/>+ <title>MyTest</title>+ </head>+ <body>+ <!--Removed Inline Script-->+ <span>Test</span>+ <script type="text/javascript">+ foo(bar);+ </script>+ </body>+</html>
+ test-data/expects/trivial.html view
@@ -0,0 +1,7 @@+<html>+ <head>+ </head>+ <body>+ <script type="text/javascript"></script>+ </body>+</html>
+ test/UnitTest.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE Rank2Types #-}++module Main where++import Test.Tasty+import Test.Tasty.Golden.Advanced+import System.Directory+import qualified System.FilePath as FP+import System.IO hiding (utf8)+import Text.Html.Consolidate+import Text.XML.HXT.Core+import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow+import Text.XML.HXT.Arrow.WriteDocument+import Control.Arrow+import Control.Monad+import Data.Char+import Control.Monad.IO.Class++main = do allCases <- getDirectoryContents casesDir+ allExpects <- getDirectoryContents expectsDir+ let validCases = getValid allCases+ let validExpects = getValid allExpects+ defaultMain $ testGroup "Tests" $+ map genTest $ filter (`elem` validExpects) validCases+ where getValid = filter $ \x -> FP.takeExtension x == ".js"++casesDir = "test-data/cases"+expectsDir = "test-data/expects"++genTest :: FilePath -> TestTree+genTest testFileName =+ let caseFileName = casesDir `FP.combine` testFileName+ expectFileName = expectsDir `FP.combine` testFileName+ ns = initialConsState False Nothing []+ state = initialState ns+ normalizedA :: String -> TArr XmlTree XmlTree+ normalizedA s = single $ parseHTML s Nothing >>> consolidateArr+ expectedA :: String -> TArr XmlTree XmlTree + expectedA s = single $ parseHTML s Nothing+ runX :: forall r s. (String -> TArr XmlTree XmlTree) -> FilePath -> ValueGetter r String+ runX a f = liftIO $ do+ s <- readFile f+ let arr :: TArr XmlTree String+ arr = (a s) >>> writeDocumentToString [withOutputHTML, withOutputEncoding utf8]+ liftM head $ runXIOState state $ arr+ expectedValueAction = runX expectedA expectFileName+ testValueAction = runX normalizedA caseFileName+ in goldenTest testFileName expectedValueAction testValueAction verifyOutput (const $ return ())++verifyOutput :: String -> String -> IO (Maybe String)+verifyOutput expected actual = return $+ let fs = filter (not . isSpace)+ msg = "Failed to match expected output to normalized input:\n\+ \Expected:\n" ++ expected ++ "\n\nSaw:\n" ++ actual ++ "\n"+ in if (fs expected == fs actual) then Nothing+ else Just msg