diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2013 Stevens Institute of Technology +Copyright (c) 2012-2015 Stevens Institute of Technology All rights reserved. diff --git a/jespresso.cabal b/jespresso.cabal --- a/jespresso.cabal +++ b/jespresso.cabal @@ -2,16 +2,16 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: jespresso -version: 1.0 +version: 1.0.1 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. +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. Note that the package versions follow Semantic Versioning model (semver.org). license: BSD3 license-file: LICENSE author: Andrey Chudnov maintainer: Andrey Chudnov Homepage: http://github.com/achudnov/jespresso Bug-reports: http://github.com/achudnov/jespresso/issues -copyright: (c) 2012-2014 Stevens Institute of Technology +copyright: (c) 2012-2015 Stevens Institute of Technology category: Web stability: Experimental tested-with: GHC==7.6.3 @@ -26,20 +26,21 @@ Source-repository this type: git location: git://github.com/achudnov/jespresso.git - tag: 1.0 + tag: 1.0.1 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 + 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.17 && < 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 + , data-default-instances-base >= 0.0.1 && < 0.1 exposed-modules: Text.Html.Consolidate Network.Browser.Simple hs-source-dirs: src @@ -47,24 +48,25 @@ 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 + 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.8 - ,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 + Build-Depends: base >= 4 && < 5 + , jespresso + , tasty >= 0.4 && < 0.11 + , tasty-golden == 2.* + , 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 + , Diff >= 0.3.0 Default-Language: Haskell2010 diff --git a/src/Text/Html/Consolidate.hs b/src/Text/Html/Consolidate.hs --- a/src/Text/Html/Consolidate.hs +++ b/src/Text/Html/Consolidate.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} -- | Extraction and consolidation of JavaScript code in an HTML page. module Text.Html.Consolidate (-- * Simple API consolidate @@ -21,6 +22,7 @@ import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.TagSoup import Language.ECMAScript3.Syntax +import Language.ECMAScript3.Syntax.CodeGen hiding (this) import Language.ECMAScript3.Syntax.Annotations import Language.ECMAScript3.PrettyPrint import Language.ECMAScript3.Parser @@ -34,8 +36,10 @@ import Data.ByteString.Lazy (ByteString) import System.Random import Data.Char -import Data.Maybe (isJust, fromJust, maybeToList) +import Data.Maybe (isJust, fromJust, maybeToList, fromMaybe) import Control.Monad hiding (when) +import Data.Default.Instances.Base +import Control.Applicative ((<$>)) -- | Consolidation state data ConsState = ConsState Bool -- Ignore errors? @@ -76,7 +80,13 @@ 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]) + in liftM head $ runXIOState state (single a >>> writeDocumentToString + -- Using plain text output to + -- prevent entity substitution on + -- special XML/HTML characters + -- that are part of inline + -- scripts + [withOutputPLAIN, 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 @@ -222,8 +232,7 @@ -- isElem >>> -- selectTags ["img", "a", "form", "frame", "iframe", "link"] >>> addIdIfNotPresent >>> - (((selectAttrValues ["src", "href", "action"] - &&& selectId) >>> + (((selectAttrValues ["src", "href", "action"] &&& selectId) >>> arr (\((url, attrName), id) -> Script () [ExprStmt () $ AssignExpr () OpAssign (LDot () (CallExpr () @@ -245,19 +254,29 @@ "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)]) + in addIdIfNotPresent >>> + (((selectId &&& selectAttrValues attrNames) >>> + arr (\(id, (handler, attrName)) -> makeHandler id attrName handler) >>> appendScript) &&& removeAttributes attrNames) >>> arr snd +makeHandler :: Default a => String -> String -> String -> JavaScript a +makeHandler id handlerName handlerSource = + let mEventName = case handlerName of + 'o':'n':s | not $ null s -> Just s + _ -> Nothing + either2maybe (Left _) = Nothing + either2maybe (Right x)= Just x + in fromMaybe (script []) $ + do eventName <- mEventName + h <- either2maybe $ reannotate def <$> parseFromString handlerSource + return $ script [expr $ call ( + call (var "document" `dot` "getElementById") [string id] + `dot` "addEventListener") + [string eventName, lambda [] $ unJavaScript h, bool False] + ] + parseJS :: TArr String (JavaScript SourcePos) parseJS = arr (parse program "") >>> eitherToFailure @@ -348,19 +367,13 @@ 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 +removeAttributes names = + processAttrl $ none `when` (foldr (\n a -> a <+> hasName n) none names) - 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") +addIdIfNotPresent = + ((genIdA &&& this) >>> (arr2A $ addAttr "id")) `when` + (getAttrValue "id" >>> isA null) -- | Selects the id of an element or adds a new one (and returns) if -- it's not present diff --git a/test-data/cases/complex1.html b/test-data/cases/complex1.html --- a/test-data/cases/complex1.html +++ b/test-data/cases/complex1.html @@ -42,11 +42,10 @@ 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"); + } + else alert("Received invalid confirmation from the payment service. Please try again"); } } function onCartUpdate(e) { @@ -57,10 +56,12 @@ 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(); + w.postMessage(total.toString(), + "http://chudnov.com"); + if(e.preventDefault) + e.preventDefault(); e.returnValue=false; - }, true); + } - + + diff --git a/test-data/expects/form1.html b/test-data/expects/form1.html --- a/test-data/expects/form1.html +++ b/test-data/expects/form1.html @@ -1,6 +1,8 @@ -
+ +
- + + diff --git a/test-data/expects/scriptSimple1.html b/test-data/expects/scriptSimple1.html --- a/test-data/expects/scriptSimple1.html +++ b/test-data/expects/scriptSimple1.html @@ -5,9 +5,11 @@ + Test diff --git a/test/UnitTest.hs b/test/UnitTest.hs --- a/test/UnitTest.hs +++ b/test/UnitTest.hs @@ -15,6 +15,8 @@ import Control.Monad import Data.Char import Control.Monad.IO.Class +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput main = do allCases <- getDirectoryContents casesDir allExpects <- getDirectoryContents expectsDir @@ -22,7 +24,7 @@ let validExpects = getValid allExpects defaultMain $ testGroup "Tests" $ map genTest $ filter (`elem` validExpects) validCases - where getValid = filter $ \x -> FP.takeExtension x == ".js" + where getValid = filter $ \x -> FP.takeExtension x == ".html" casesDir = "test-data/cases" expectsDir = "test-data/expects" @@ -35,15 +37,14 @@ 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 + expectedValueAction :: forall r. ValueGetter r String + expectedValueAction = liftIO $ readFile expectFileName testValueAction = runX normalizedA caseFileName in goldenTest testFileName expectedValueAction testValueAction verifyOutput (const $ return ()) @@ -51,6 +52,6 @@ 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" + \Diff:\n" ++ ppDiff (getGroupedDiff (lines expected) (lines actual)) in if (fs expected == fs actual) then Nothing else Just msg