diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Change Log +## hs-webdriver 0.3.3 + +###bug fixes +*The default preferences used by Selenium are now merged into the preferences of Firefox profiles loaded from disk. +*addExtension will now correctly add extension directories to a profile. + +###API changes +* The representation of profile files has been changed to use a HashMap instead of an association list. This ensures that destination paths are always unique. + +###new features +*It's now possible to add entire directories to a profile in pure code using addFile and addExtension. +*new functions in Common.Profile: unionProfiles, onProfileFiles, onProfilePrefs +*new function in Commands.Wait: onTimeout +*the WD monad now has a MonadCatchIO instance, as an alternative to lifted-base for exception handling + + ## hs-webdriver 0.3.2.1 ###bug fixes diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,5 +1,11 @@ -for next release +in upcoming releases +-- fix loadProfile so that it doesn't cause an overlap with user addExtension calls + +-- add support for new experimental IE capabilities + +-- add support for Opera profiles + -- improve documentation. Document errors. -- provide examples -- basic runSession usage @@ -9,24 +15,21 @@ -- firefox profile usage -- REPL usage + for 1.0 -- add WDSettings, use WDSession as internal State type. -- allow settings to automatically load drivers. add modules with driver loading functions --- allow setting to modify HTTP headers +-- use http-conduit and attoparsec-conduit to stream JSON data. use request methods from http-types distant future --- use http-conduit and attoparsec-conduit to stream JSON data. use request methods from http-types - -- use ReaderT to store WDVersion for use with implicit configurations. misc. unsorted --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/Classes.hs b/src/Test/WebDriver/Classes.hs --- a/src/Test/WebDriver/Classes.hs +++ b/src/Test/WebDriver/Classes.hs @@ -25,8 +25,8 @@ import Data.Typeable import Control.Monad.Trans.Maybe -import Control.Monad.List import Control.Monad.Trans.Identity +import Control.Monad.List import Control.Monad.Reader import Control.Monad.Error --import Control.Monad.Cont 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 @@ -6,6 +6,7 @@ -- * Expected conditions , ExpectFailed, expect, unexpected -- ** Convenience functions + , onTimeout , expectAny, expectAll , ifM, (<||>), (<&&>), notM ) where @@ -37,19 +38,20 @@ | b = return () | otherwise = unexpected --- |Apply a predicate to every element in a list, and expect that at least one --- succeeds. +-- |Apply a monadic predicate to every element in a list, and 'expect' that +-- at least one succeeds. expectAny :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m () expectAny p xs = expect . or =<< mapM p xs --- |Apply a predicate to every element in a list, and expect that all succeed. +-- |Apply a monadic predicate to every element in a list, and 'expect' that all +-- succeed. expectAll :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m () expectAll p xs = expect . and =<< mapM p xs -- |Wait until either the given action succeeds or the timeout is reached. -- The action will be retried every .25 seconds until no 'ExpectFailed' or --- 'Test.WebDriver.NoSuchElement' exceptions occur. If the timeout is reached, --- then a 'Test.WebDriver.Timeout' exception will be raised. The timeout value +-- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached, +-- then a 'Timeout' exception will be raised. The timeout value -- is expressed in seconds. waitUntil :: SessionState m => Double -> m a -> m a waitUntil = waitUntil' 500000 @@ -100,6 +102,19 @@ if diffUTCTime now startTime >= timeout then failedCommand Timeout "wait': explicit wait timed out." - else do + else do liftBase . threadDelay $ waitAmnt waitLoop startTime + +-- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions +-- and perform some action. +-- +-- Example: +-- +-- > waitUntil 5 (getText <=< findElem $ ByCSS ".class") +-- > `onTimeout` return "" +onTimeout :: MonadBaseControl IO m => m a -> m a -> m a +onTimeout m r = m `catch` handler + where + handler (FailedCommand Timeout _) = r + handler other = throwIO other 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 @@ -10,8 +10,10 @@ , getPref, addPref, deletePref -- * Extensions , addExtension, deleteExtension, hasExtension - -- * Other files + -- * Other files and directories , addFile, deleteFile, hasFile + -- * Miscellaneous profile operations + , unionProfiles, onProfileFiles, onProfilePrefs -- *Preparing profiles from disk , prepareLoadedProfile_ -- *Preparing zipped profiles @@ -21,9 +23,13 @@ , ProfileParseError(..) ) where +import System.Directory +import System.FilePath hiding (addExtension, hasExtension) +import Codec.Archive.Zip import Data.Aeson import Data.Aeson.Types import Data.Attoparsec.Number (Number(..)) + import qualified Data.HashMap.Strict as HM import Data.Text (Text, pack) import Data.ByteString (ByteString) @@ -31,17 +37,11 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Base64 as B64 -import Codec.Archive.Zip -import System.Directory -import System.FilePath hiding (addExtension, hasExtension) - import Data.Fixed import Data.Ratio import Data.Int import Data.Word -import Data.List -import Data.Maybe import Data.Typeable import Control.Exception @@ -50,14 +50,18 @@ -- |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 +-- type is shared by both Firefox and Opera profiles; when a distinction -- must be made, the phantom type parameter is used to differentiate. data Profile b = Profile - { -- |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 mapping from relative destination filepaths to source + -- filepaths found on the filesystem. When the profile is + -- prepared, these source filepaths will be moved to their + -- destinations within the profile directory. + -- + -- Using the destination path as the key ensures that + -- there is one unique source path going to each + -- destination path. + profileFiles :: HM.HashMap FilePath FilePath -- |A map of Firefox preferences. These are the settings -- found in the profile's prefs.js, and entries found in -- about:config @@ -152,32 +156,32 @@ -- |Add a new preference entry to a profile, overwriting any existing entry -- with the same key. addPref :: ToPref a => Text -> a -> Profile b -> Profile b -addPref k v p = asMap p $ HM.insert k (toPref v) +addPref k v p = onProfilePrefs p $ HM.insert k (toPref v) -- |Delete an existing preference entry from a profile. This operation is -- silent if the preference wasn't found. deletePref :: Text -> Profile b -> Profile b -deletePref k p = asMap p $ HM.delete k +deletePref k p = onProfilePrefs 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. +-- as a path relative to a profile directory. Overwrites any file that +-- previously pointed to the same destination addFile :: FilePath -> FilePath -> Profile b -> Profile b -addFile src dest p = asList p ((src, dest):) +addFile src dest p = onProfileFiles p $ HM.insert dest src -- |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) +deleteFile path prof = onProfileFiles prof $ HM.delete path --- |Determines if a profile contains the given file. specified as a path relative to --- the profile directory. +-- |Determines if a profile contains the given file, specified as a path +-- relative to the profile directory. hasFile :: String -> Profile b -> Bool -hasFile path (Profile files _) = isJust $ find (\(_,d) -> d == path) files +hasFile path (Profile files _) = path `HM.member` files -- |Add a new extension to the profile. The file path should refer to --- an .xpi file or an extension directory on the filesystem. If possible, --- you should avoiding adding the same extension twice to a given profile. +-- a .xpi file or an extension directory on the filesystem. addExtension :: FilePath -> Profile b -> Profile b addExtension path = addFile path ("extensions" name) where (_, name) = splitFileName path @@ -189,20 +193,31 @@ deleteExtension :: String -> Profile b -> Profile b deleteExtension name = deleteFile ("extensions" name) --- |Determines if a profile contains the given extension. specified as an .xpi file --- or directory name +-- |Determines if a profile contains the given extension. specified as an +-- .xpi file or directory name hasExtension :: String -> Profile b -> Bool hasExtension name prof = hasFile ("extensions" name) prof -asMap :: Profile b - -> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref) - -> Profile b -asMap (Profile hs hm) f = Profile hs (f hm) -asList :: Profile b - -> ([(FilePath, FilePath)] -> [(FilePath, FilePath)]) - -> Profile b -asList (Profile ls hm) f = Profile (f ls) hm +-- |Takes the union of two profiles. This is the union of their 'HashMap' +-- fields. +unionProfiles :: Profile b -> Profile b -> Profile b +unionProfiles (Profile f1 p1) (Profile f2 p2) + = Profile (f1 `HM.union` f2) (p1 `HM.union` p2) + +-- |Modifies the 'profilePrefs' field of a profile. +onProfilePrefs :: Profile b + -> (HM.HashMap Text ProfilePref + -> HM.HashMap Text ProfilePref) + -> Profile b +onProfilePrefs (Profile hs hm) f = Profile hs (f hm) + +-- |Modifies the 'profileFiles' field of a profile +onProfileFiles :: Profile b + -> (HM.HashMap FilePath FilePath + -> HM.HashMap FilePath FilePath) + -> Profile b +onProfileFiles (Profile ls hm) f = Profile (f ls) hm -- |Efficiently load an existing profile from disk and prepare it for network 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 @@ -13,8 +13,10 @@ , addPref, getPref, deletePref -- * Extensions , addExtension, deleteExtension, hasExtension - -- * Other Files + -- * Other files and directories , addFile, removeFile, hasFile + -- * Miscellaneous profile operations + , unionProfiles, onProfileFiles, onProfilePrefs -- * Loading and preparing profiles , prepareProfile, prepareTempProfile -- ** Preparing profiles from disk @@ -41,17 +43,20 @@ import Control.Monad import Control.Monad.Base import Control.Monad.Trans.Control +import Control.Exception.Lifted hiding (try) import Control.Applicative +import Control.Arrow 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 +-- |Default Firefox Profile, used when no profile is supplied. defaultProfile :: Profile Firefox defaultProfile = - Profile [] + Profile HM.empty $ HM.fromList [("app.update.auto", PrefBool False) ,("app.update.enabled", PrefBool False) ,("browser.startup.page" , PrefInteger 0) @@ -116,24 +121,26 @@ -- |Load an existing profile from the file system. Any prepared changes made to -- the 'Profile' will have no effect to the profile on disk. +-- +-- To make automated browser run smoothly, preferences found in +-- 'defaultProfile' are automatically merged into the preferences of the on-disk-- profile. The on-disk profile's preference will override those found in the +-- default profile. loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox) loadProfile path = liftBase $ do - Profile <$> getFiles <*> getPrefs + unionProfiles defaultProfile <$> (Profile <$> getFiles <*> getPrefs) where - getFiles = do - d <- FS.getDirectory' path - case FS.filter (not.isIgnored) [d] of - [d'] -> return $ FS.zipWithDest (,) "" d' - _ -> return [] - where isIgnored p = "Cache/" `isInfixOf` p - || "OfflineCache/" `isInfixOf` p - || "lock" `isSuffixOf` p + userPrefFile = path "prefs" <.> "js" - userPref = path "prefs" <.> "js" - getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPref) - parsePrefs s = either (throwIO . ProfileParseError) - return - $ parseOnly prefsParser s + getFiles = HM.fromList . map (id &&& (path )) . filter isNotIgnored + <$> getDirectoryContents path + where isNotIgnored = (`notElem` + [".", "..", "OfflineCache", "Cache" + ,"parent.lock", ".parentlock", ".lock" + ,userPrefFile]) + + getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile) + where 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 @@ -149,16 +156,19 @@ prepareProfile Profile {profileFiles = files, profilePrefs = prefs} = liftBase $ do tmpdir <- mkTemp - mapM_ (installPath tmpdir) files + mapM_ (installPath tmpdir) . HM.toList $ files installUserPrefs tmpdir prepareLoadedProfile_ tmpdir - <* removeDirectoryRecursive tmpdir +-- <* removeDirectoryRecursive tmpdir where - installPath destDir (src, destPath) = do + installPath destDir (destPath, src) = do let dest = destDir destPath isDir <- doesDirectoryExist src if isDir - then createDirectoryIfMissing True dest `catch` ignoreIOException + then do + createDirectoryIfMissing True dest `catch` ignoreIOException + FS.getDirectory src + >>= handle ignoreIOException . FS.copyTo_ dest else do let dir = takeDirectory dest when (not . null $ dir) $ diff --git a/src/Test/WebDriver/Monad.hs b/src/Test/WebDriver/Monad.hs --- a/src/Test/WebDriver/Monad.hs +++ b/src/Test/WebDriver/Monad.hs @@ -16,13 +16,14 @@ import Control.Monad.State.Strict (StateT, MonadState, evalStateT, get, put) import Control.Monad.IO.Class (MonadIO) import Control.Exception.Lifted +import Control.Monad.CatchIO (MonadCatchIO) import Control.Applicative {- |A monadic interface to the WebDriver server. This monad is a simple, strict layer over 'IO', threading session information between sequential commands -} newtype WD a = WD (StateT WDSession IO a) - deriving (Functor, Monad, MonadIO, Applicative) + deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) instance MonadBase IO WD where liftBase = WD . liftBase diff --git a/webdriver.cabal b/webdriver.cabal --- a/webdriver.cabal +++ b/webdriver.cabal @@ -1,5 +1,5 @@ Name: webdriver -Version: 0.3.2.1 +Version: 0.3.3 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE @@ -47,6 +47,7 @@ , transformers-base < 1.0 , vector >= 0.3 , lifted-base == 0.1.* + , MonadCatchIO-transformers >= 0.3 && < 0.4 , filesystem-trees >= 0.1.0.2 && < 0.2 , data-default , temporary