diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,23 @@ -#0.3.0.1 +# Change Log ## upcoming release + +###API changes +*The representation of Profiles has changed, allowing it to store arbitrary files as well as extensions. The functional API for working with preferences and extensions ismostly unchanged, except for the behavior of calling addExtension consecutively with the same filepath argument. +*The old <&&> and <||> operators in Test.WebDriver.Commands.Wait have been removed and replaced with the ones exported from Control.Conditional from the cond package. + +###bug fixes +*Fixed memory leak resulting from an infinite recursion in the FromJSON instance of PreparedProfile. +*loadProfile now properly loads an entire Firefox profile from disk, rather than just the extensions and preferences. + +###known issues +*An issue involving lazy bytestring IO in the zip-archive package means that unusually large profiles might exceed the OSes open file limit. + +###new features +*several new functions for working with Firefox/Opera profiles have been added. This includes functions for loading large profiles from disk, functions for working with zipped profiles, and functions for adding arbitrary files to a profile in pure code. +*new helper functions were added to Test.WebDriver.Commands.Wait, exported from the cond package. + +## hs-webdriver 0.3.0.1 ###bug fixes *due to a nonconformance in the spec from the Grid server, wire responses were being received that contained no sessionId key, which subsequently resulted in a parse error from our JSON parser. This has been fixed, so that an omitted sessionId defaults to Nothing. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -27,8 +27,6 @@ misc. unsorted --- remove temporary directory code from prepareProfile - --Use lazy ByteString where possible. patch base64-bytestring to work with lazy bytestrings -- add support for new experimental IE capabilities diff --git a/src/Test/WebDriver/Commands.hs b/src/Test/WebDriver/Commands.hs --- a/src/Test/WebDriver/Commands.hs +++ b/src/Test/WebDriver/Commands.hs @@ -83,7 +83,7 @@ import Data.ByteString as SBS (ByteString, concat) import Data.ByteString.Base64 as B64 import Data.ByteString.Lazy as LBS (ByteString, toChunks) -import Network.URI +import Network.URI hiding (path) -- suppresses warnings import Codec.Archive.Zip import Control.Applicative diff --git a/src/Test/WebDriver/Commands/Wait.hs b/src/Test/WebDriver/Commands/Wait.hs --- a/src/Test/WebDriver/Commands/Wait.hs +++ b/src/Test/WebDriver/Commands/Wait.hs @@ -7,7 +7,7 @@ , ExpectFailed, expect, unexpected -- ** Convenience functions , expectAny, expectAll - , (<||>), (<&&>) + , ifM, (<||>), (<&&>), notM ) where import Test.WebDriver.Exceptions import Test.WebDriver.Classes @@ -18,6 +18,7 @@ import Control.Concurrent import Data.Time.Clock import Data.Typeable +import Control.Conditional import Prelude hiding (catch) instance Exception ExpectFailed @@ -35,16 +36,6 @@ expect b | b = return () | otherwise = unexpected - - --- |Lifted boolean and -(<&&>) :: Monad m => m Bool -> m Bool -> m Bool -(<&&>) = liftM2 (&&) - --- |Lifted boolean or -(<||>) :: Monad m => m Bool -> m Bool -> m Bool -(<||>) = liftM2 (||) - -- |Apply a predicate to every element in a list, and expect that at least one -- succeeds. diff --git a/src/Test/WebDriver/Common/Profile.hs b/src/Test/WebDriver/Common/Profile.hs --- a/src/Test/WebDriver/Common/Profile.hs +++ b/src/Test/WebDriver/Common/Profile.hs @@ -1,21 +1,36 @@ {-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, - GeneralizedNewtypeDeriving, OverloadedStrings #-} + GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleContexts #-} {-# OPTIONS_HADDOCK not-home #-} -- |A type for profile preferences. These preference values are used by both -- Firefox and Opera profiles. module Test.WebDriver.Common.Profile - ( Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..) + ( -- *Profiles and profile preferences + Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..) , getPref, addPref, deletePref, addExtension, deleteExtension - , ProfileParseError(..) ) where + -- *Preparing profiles from disk + , prepareLoadedProfile_ + -- *Preparing zipped profiles + , prepareZippedProfile, prepareZipArchive, + prepareRawZip + -- *Profile errors + , ProfileParseError(..) + ) where import Data.Aeson import Data.Aeson.Types import Data.Attoparsec.Number (Number(..)) import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS import Data.Text (Text, pack) import Data.ByteString (ByteString) +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Base64 as B64 + +import Codec.Archive.Zip +import System.FilePath hiding (addExtension) + + import Data.Fixed import Data.Ratio import Data.Int @@ -24,16 +39,18 @@ import Data.Typeable import Control.Exception import Control.Applicative +import Control.Monad.Base -- |This structure allows you to construct and manipulate profiles in pure code, -- deferring execution of IO operations until the profile is \"prepared\". This -- type is shared by both Firefox and Opera profile code; when a distinction -- must be made, the phantom type parameter is used to differentiate. data Profile b = Profile - { -- |Location of the profile in the local file system - profileDir :: FilePath - -- |A set of filepaths pointing to browser extensions. - , profileExts :: HS.HashSet FilePath + { -- |A set of filepaths pointing to files to place in + -- the extension directory. The first tuple element is the source + -- path. The second tuple element is the destination path + -- relative to the extension of the file. + profileFiles :: [(FilePath, FilePath)] -- |A map of Firefox preferences. These are the settings -- found in the profile's prefs.js, and entries found in -- about:config @@ -51,7 +68,7 @@ parseJSON other = typeMismatch "PreparedProfile" other instance ToJSON (PreparedProfile s) where - toJSON s = object ["zip" .= s] + toJSON (PreparedProfile s) = object ["zip" .= s] -- |A profile preference value. This is the subset of JSON values that excludes -- arrays, objects, and null. @@ -124,7 +141,7 @@ -- |Retrieve a preference from a profile by key name. getPref :: Text -> Profile b -> Maybe ProfilePref -getPref k (Profile _ _ m) = HM.lookup k m +getPref k (Profile _ m) = HM.lookup k m -- |Add a new preference entry to a profile, overwriting any existing entry -- with the same key. @@ -136,24 +153,60 @@ deletePref :: Text -> Profile b -> Profile b deletePref k p = asMap p $ HM.delete k +-- |Add a file to the profile directory. The first argument is the source +-- of the file on the local filesystem. The second argument is the destination +-- as a path relative to a profile directory. +addFile :: FilePath -> FilePath -> Profile b -> Profile b +addFile src dest p = asList p ((src, dest):) + +-- |Delete a file from the profile directory. The first argument is the name of +-- file within the profile directory. +deleteFile :: FilePath -> Profile b -> Profile b +deleteFile path prof = asList prof $ filter (\(_,p) -> p == path) + -- |Add a new extension to the profile. The file path should refer to --- an .xpi file or an extension directory. This operation has no effect if --- the same extension has already been added to this profile. +-- an .xpi file or an extension directory on the filesystem. If possible, +-- you should avoiding adding the same extension twice to a given profile. addExtension :: FilePath -> Profile b -> Profile b -addExtension path p = asSet p $ HS.insert path +addExtension path = addFile path ("extensions/" name) + where (_, name) = splitFileName path --- |Delete an existing extension from the profile. The file path should refer --- to an .xpi file or an extension directory. This operation has no effect if --- the extension was never added to the profile. -deleteExtension :: FilePath -> Profile b -> Profile b -deleteExtension path p = asSet p $ HS.delete path +-- |Delete an existing extension from the profile. The string parameter +-- should refer to an .xpi file or directory located within the extensions +-- directory of the profile. This operation has no effect if the extension was +-- never added to the profile. +deleteExtension :: String -> Profile b -> Profile b +deleteExtension name = deleteFile ("extensions/" name) asMap :: Profile b -> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref) -> Profile b -asMap (Profile p hs hm) f = Profile p hs (f hm) +asMap (Profile hs hm) f = Profile hs (f hm) -asSet :: Profile b - -> (HS.HashSet FilePath -> HS.HashSet FilePath) +asList :: Profile b + -> ([(FilePath, FilePath)] -> [(FilePath, FilePath)]) -> Profile b -asSet (Profile p hs hm) f = Profile p (f hs) hm +asList (Profile ls hm) f = Profile (f ls) hm + + +-- |Efficiently load an existing profile from disk and prepare it for network +-- transmission. +prepareLoadedProfile_ :: MonadBase IO m => + FilePath -> m (PreparedProfile a) +prepareLoadedProfile_ path = prepareZipArchive <$> + liftBase (addFilesToArchive [OptRecursive] + emptyArchive [path]) + +-- |Prepare a zip file of a profile on disk for network transmission. +-- This function is very efficient at loading large profiles from disk. +prepareZippedProfile :: MonadBase IO m => + FilePath -> m (PreparedProfile a) +prepareZippedProfile path = prepareRawZip <$> liftBase (LBS.readFile path) + +-- |Prepare a zip archive of a profile for network transmission. +prepareZipArchive :: Archive -> PreparedProfile a +prepareZipArchive = prepareRawZip . fromArchive + +-- |Prepare a ByteString of raw zip data for network transmission +prepareRawZip :: LBS.ByteString -> PreparedProfile a +prepareRawZip = PreparedProfile . B64.encode . SBS.concat . LBS.toChunks diff --git a/src/Test/WebDriver/Firefox/Profile.hs b/src/Test/WebDriver/Firefox/Profile.hs --- a/src/Test/WebDriver/Firefox/Profile.hs +++ b/src/Test/WebDriver/Firefox/Profile.hs @@ -1,128 +1,55 @@ {-# LANGUAGE CPP, OverloadedStrings, FlexibleContexts, - GeneralizedNewtypeDeriving, EmptyDataDecls #-} + GeneralizedNewtypeDeriving, EmptyDataDecls, + ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- suppress warnings from attoparsec -- |A module for working with Firefox profiles. Firefox profiles are manipulated -- in pure code and then \"prepared\" for network transmission. module Test.WebDriver.Firefox.Profile ( -- * Profiles Firefox, Profile(..), PreparedProfile + , defaultProfile -- * Preferences , ProfilePref(..), ToPref(..) , addPref, getPref, deletePref -- * Extensions , addExtension, deleteExtension -- * Loading and preparing profiles - , loadProfile, prepareProfile - , prepareTempProfile, prepareLoadedProfile + , prepareProfile, prepareTempProfile + -- ** Preparing profiles from disk + , loadProfile, prepareLoadedProfile, prepareLoadedProfile_ + -- ** Preparing zip archives + , prepareZippedProfile, prepareZipArchive, prepareRawZip ) where import Test.WebDriver.Common.Profile import Data.Aeson import Data.Aeson.Parser (jstring, value') import Data.Attoparsec.Char8 as AP import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS import Data.Text (Text) import Data.ByteString as BS (readFile) -import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.ByteString.Base64 as B64 -import System.IO -import System.FilePath hiding (hasExtension, addExtension) +import System.FilePath hiding (addExtension) import System.Directory -import System.IO.Temp +import System.IO.Temp (createTempDirectory) +import qualified System.File.Tree as FS import Codec.Archive.Zip -import Distribution.Simple.Utils -import Distribution.Verbosity import Control.Monad import Control.Monad.Base import Control.Monad.Trans.Control import Control.Applicative +import Data.List import Control.Exception.Lifted hiding (try) +import Prelude hiding (catch) -- |Phantom type used in the parameters of 'Profile' and 'PreparedProfile' data Firefox -tempProfile :: MonadBase IO m => m (Profile Firefox) -tempProfile = liftBase $ defaultProfile <$> mkTemp - --- |Load an existing profile from the file system. Any prepared changes made to --- the 'Profile' will have no effect to the profile on disk. -loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox) -loadProfile path = liftBase $ do - Profile{ profileDir = d } <- tempProfile - Profile <$> pure d <*> getExtensions <*> getPrefs - where - extD = path "extensions" - userPref = path "prefs" <.> "js" - getExtensions = do - b <- doesDirectoryExist extD - if b - then HS.fromList . map (extD ) . filter (`notElem` [".",".."]) - <$> getDirectoryContents extD - else return HS.empty - getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPref) - - parsePrefs s = either (throwIO . ProfileParseError) - return - $ parseOnly prefsParser s - --- |Prepare a firefox profile for network transmission. --- Internally, this function constructs a Firefox profile within a temp --- directory, archives it as a zip file, and then base64 encodes the zipped --- data. The temporary directory is deleted afterwards -prepareProfile :: MonadBase IO m => - Profile Firefox -> m (PreparedProfile Firefox) -prepareProfile Profile {profileDir = d, profileExts = s, - profilePrefs = m} - = liftBase $ do - createDirectoryIfMissing False extensionD - extPaths <- mapM canonicalizePath . HS.toList $ s - forM_ extPaths installExtension - withFile userPrefs WriteMode writeUserPrefs - prof <- PreparedProfile . B64.encode . SBS.concat . LBS.toChunks - . fromArchive - <$> addFilesToArchive [OptRecursive] emptyArchive [d] - removeDirectoryRecursive d - return prof - where - extensionD = d "extensions" - userPrefs = d "user" <.> "js" - - installExtension ePath = - case splitExtension ePath of - (_,".xpi") -> installOrdinaryFile silent ePath dest - _ -> installDirectoryContents silent ePath dest - where - dest = extensionD eFile - (_,eFile) = splitFileName ePath - - writeUserPrefs h = - forM_ (HM.toList m) $ \(k, v) -> - LBS.hPut h . LBS.concat - $ [ "user_pref(", encode k, ", ", encode v, ");\n"] - - --- |Apply a function on an automatically generated default profile, and --- prepare the result. The Profile passed to the handler function is --- the default profile used by sessions when Nothing is specified -prepareTempProfile :: MonadBase IO m => - (Profile Firefox -> Profile Firefox) - -> m (PreparedProfile Firefox) -prepareTempProfile f = liftM f tempProfile >>= prepareProfile - --- |Convenience function to load an existing Firefox profile from disk, apply --- a handler function, and then prepare the result for network transmission. -prepareLoadedProfile :: MonadBaseControl IO m => - FilePath - -> (Profile Firefox -> Profile Firefox) - -> m (PreparedProfile Firefox) -prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile - -defaultProfile :: FilePath -> Profile Firefox -defaultProfile d = - Profile d HS.empty +defaultProfile :: Profile Firefox +defaultProfile = + Profile [] $ HM.fromList [("app.update.auto", PrefBool False) ,("app.update.enabled", PrefBool False) ,("browser.startup.page" , PrefInteger 0) @@ -184,10 +111,87 @@ native_events = PrefBool True #endif -mkTemp :: IO FilePath -mkTemp = do - d <- getTemporaryDirectory - createTempDirectory d "" + +-- |Load an existing profile from the file system. Any prepared changes made to +-- the 'Profile' will have no effect to the profile on disk. +loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox) +loadProfile path = liftBase $ do + Profile <$> getFiles <*> getPrefs + where + getFiles = do + d <- FS.getDirectory path + case FS.filter (not.isIgnored) [d] of + [t] -> return $ FS.zipWithDest (,) "" t + _ -> return [] + where isIgnored p = "Cache/" `isInfixOf` p + || "OfflineCache/" `isInfixOf` p + || "lock" `isSuffixOf` p + + userPref = path "prefs" <.> "js" + getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPref) + parsePrefs s = either (throwIO . ProfileParseError) + return + $ parseOnly prefsParser s + +-- |Prepare a firefox profile for network transmission. +-- Internally, this function constructs a Firefox profile within a temp +-- directory, archives it as a zip file, and then base64 encodes the zipped +-- data. The temporary directory is deleted afterwards. +-- +-- NOTE: because this function has to copy the profile files into a +-- a temp directory before zip archiving them, this operation is likely to be slow +-- for large profiles. In such a case, consider using 'prepareLoadedProfile_' or +-- 'prepareZippedProfile' instead. +prepareProfile :: MonadBaseControl IO m => + Profile Firefox -> m (PreparedProfile Firefox) +prepareProfile Profile {profileFiles = files, profilePrefs = prefs} + = liftBase $ do + tmpdir <- mkTemp + mapM_ (installPath tmpdir) files + archive <- addUserPrefs <$> addFilesToArchive [OptRecursive] + emptyArchive [tmpdir] + removeDirectoryRecursive tmpdir + return . prepareZipArchive $ archive + where + installPath tmp (src, d) = do + let dest = tmp d + isDir <- doesDirectoryExist src + if isDir + then createDirectoryIfMissing True dest `catch` ignoreIOException + else do + let dir = takeDirectory dest + when (not . null $ dir) $ + createDirectoryIfMissing True dir `catch` ignoreIOException + copyFile src dest `catch` ignoreIOException + + ignoreIOException :: IOException -> IO () + ignoreIOException = print + + addUserPrefs = addEntryToArchive e + where + e = toEntry ("user" <.> "js") 0 + . LBS.concat + . map (\(k, v) -> LBS.concat [ "user_pref(", encode k, + ", ", encode v, ");\n"]) + . HM.toList $ prefs + +-- |Apply a function on a default profile, and +-- prepare the result. The Profile passed to the handler function is +-- the default profile used by sessions when Nothing is specified +prepareTempProfile :: MonadBaseControl IO m => + (Profile Firefox -> Profile Firefox) + -> m (PreparedProfile Firefox) +prepareTempProfile f = prepareProfile . f $ defaultProfile + +-- |Convenience function to load an existing Firefox profile from disk, apply +-- a handler function, and then prepare the result for network transmission. +-- +-- NOTE: like 'prepareProfile', the same caveat about large profiles applies. +prepareLoadedProfile :: MonadBaseControl IO m => + FilePath + -> (Profile Firefox -> Profile Firefox) + -> m (PreparedProfile Firefox) +prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile -- firefox prefs.js parser @@ -213,3 +217,9 @@ comment = inlineComment <|> lineComment lineComment = char '#' *> manyTill anyChar endOfLine inlineComment = string "/*" *> manyTill anyChar (string "*/") + + +mkTemp :: IO FilePath +mkTemp = do + d <- getTemporaryDirectory + createTempDirectory d "" diff --git a/src/Test/WebDriver/Internal.hs b/src/Test/WebDriver/Internal.hs --- a/src/Test/WebDriver/Internal.hs +++ b/src/Test/WebDriver/Internal.hs @@ -70,7 +70,6 @@ ] } r <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return - liftBase . print . rspBody $ r return r handleHTTPErr :: SessionState s => Response ByteString -> s () @@ -236,6 +235,8 @@ } deriving (Eq) +-- |Provides a readable printout of the error information, useful for +-- logging. instance Show FailedCommandInfo where show i = showChar '\n' . showString "Session: " . sess diff --git a/webdriver.cabal b/webdriver.cabal --- a/webdriver.cabal +++ b/webdriver.cabal @@ -1,5 +1,5 @@ Name: webdriver -Version: 0.3.0.1 +Version: 0.3.1 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE @@ -38,7 +38,6 @@ , text >= 0.7 && < 0.12 , time == 1.* , transformers >= 0.2 - , Cabal >= 1.6 , zip-archive >= 0.1.1.7 , directory == 1.* , filepath >=1.1 @@ -48,9 +47,11 @@ , transformers-base < 1.0 , vector >= 0.3 , lifted-base == 0.1.* + , filesystem-trees == 0.0.* , data-default - , base64-bytestring , temporary + , base64-bytestring + , cond >= 0.3 && < 0.5 exposed-modules: Test.WebDriver Test.WebDriver.Classes