{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Test.WebDriver.Firefox.Profile
(
Firefox, Profile(..), PreparedProfile
, defaultProfile
, ProfilePref(..), ToPref(..)
, addPref, getPref, deletePref
, addExtension, deleteExtension, hasExtension
, addFile, deleteFile, hasFile
, unionProfiles, onProfileFiles, onProfilePrefs
, prepareProfile, prepareTempProfile
, loadProfile, prepareLoadedProfile, prepareLoadedProfile_
, prepareZippedProfile, prepareZipArchive, prepareRawZip
, ProfileParseError(..)
) where
import Test.WebDriver.Common.Profile
import Data.Aeson (Result(..), encode, fromJSON)
import Data.Aeson.Parser (jstring, value')
import Data.Attoparsec.ByteString.Char8 as AP
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import Data.ByteString as BS (readFile)
import qualified Data.ByteString.Lazy.Char8 as LBS
import System.FilePath hiding (addExtension, hasExtension)
import System.Directory
import System.IO.Temp (createTempDirectory)
import qualified System.Directory.Tree as DS
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Exception.Lifted hiding (try)
import Control.Applicative
import Control.Arrow
#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
import Prelude hiding (catch)
#endif
data Firefox
defaultProfile :: Profile Firefox
defaultProfile :: Profile Firefox
defaultProfile =
forall b.
HashMap FilePath FilePath -> HashMap Text ProfilePref -> Profile b
Profile forall k v. HashMap k v
HM.empty
forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text
"app.update.auto", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"app.update.enabled", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.startup.page" , Integer -> ProfilePref
PrefInteger Integer
0)
,(Text
"browser.download.manager.showWhenStarting", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.EULA.override", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"browser.EULA.3.accepted", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"browser.link.open_external", Integer -> ProfilePref
PrefInteger Integer
2)
,(Text
"browser.link.open_newwindow", Integer -> ProfilePref
PrefInteger Integer
2)
,(Text
"browser.offline", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.safebrowsing.enabled", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.search.update", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.sessionstore.resume_from_crash", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.shell.checkDefaultBrowser", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.tabs.warnOnClose", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.tabs.warnOnOpen", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"browser.startup.page", Integer -> ProfilePref
PrefInteger Integer
0)
,(Text
"browser.safebrowsing.malware.enabled", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"startup.homepage_welcome_url", Text -> ProfilePref
PrefString Text
"about:blank")
,(Text
"devtools.errorconsole.enabled", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"focusmanager.testmode", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"dom.disable_open_during_load", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"extensions.autoDisableScopes" , Integer -> ProfilePref
PrefInteger Integer
10)
,(Text
"extensions.logging.enabled", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"extensions.update.enabled", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"extensions.update.notifyUser", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"network.manage-offline-status", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"network.http.max-connections-per-server", Integer -> ProfilePref
PrefInteger Integer
10)
,(Text
"network.http.phishy-userpass-length", Integer -> ProfilePref
PrefInteger Integer
255)
,(Text
"offline-apps.allow_by_default", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"prompts.tab_modal.enabled", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.fileuri.origin_policy", Integer -> ProfilePref
PrefInteger Integer
3)
,(Text
"security.fileuri.strict_origin_policy", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_entering_secure", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_submit_insecure", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_entering_secure.show_once", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_entering_weak", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_entering_weak.show_once", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_leaving_secure", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_leaving_secure.show_once", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_submit_insecure", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_viewing_mixed", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"security.warn_viewing_mixed.show_once", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"signon.rememberSignons", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"toolkit.networkmanager.disable", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"toolkit.telemetry.enabled", Bool -> ProfilePref
PrefBool Bool
False)
,(Text
"toolkit.telemetry.prompted", Integer -> ProfilePref
PrefInteger Integer
2)
,(Text
"toolkit.telemetry.rejected", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"javascript.options.showInConsole", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"browser.dom.window.dump.enabled", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"webdriver_accept_untrusted_certs", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"webdriver_enable_native_events", ProfilePref
native_events)
,(Text
"webdriver_assume_untrusted_issuer", Bool -> ProfilePref
PrefBool Bool
True)
,(Text
"dom.max_script_run_time", Integer -> ProfilePref
PrefInteger Integer
30)
]
where
#ifdef darwin_HOST_OS
native_events = PrefBool False
#else
native_events :: ProfilePref
native_events = Bool -> ProfilePref
PrefBool Bool
True
#endif
loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox)
loadProfile :: forall (m :: * -> *).
MonadBaseControl IO m =>
FilePath -> m (Profile Firefox)
loadProfile FilePath
path = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ do
forall b. Profile b -> Profile b -> Profile b
unionProfiles Profile Firefox
defaultProfile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b.
HashMap FilePath FilePath -> HashMap Text ProfilePref -> Profile b
Profile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (HashMap FilePath FilePath)
getFiles forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashMap Text ProfilePref)
getPrefs)
where
userPrefFile :: FilePath
userPrefFile = FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
"prefs" FilePath -> FilePath -> FilePath
<.> FilePath
"js"
getFiles :: IO (HashMap FilePath FilePath)
getFiles = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (FilePath
path FilePath -> FilePath -> FilePath
</>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isNotIgnored
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
path
where isNotIgnored :: FilePath -> Bool
isNotIgnored = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
[FilePath
".", FilePath
"..", FilePath
"OfflineCache", FilePath
"Cache"
,FilePath
"parent.lock", FilePath
".parentlock", FilePath
".lock"
,FilePath
userPrefFile])
getPrefs :: IO (HashMap Text ProfilePref)
getPrefs = do
Bool
prefFileExists <- FilePath -> IO Bool
doesFileExist FilePath
userPrefFile
if Bool
prefFileExists
then forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {m :: * -> *}.
MonadBase IO m =>
ByteString -> m [(Text, ProfilePref)]
parsePrefs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
BS.readFile FilePath
userPrefFile)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall k v. HashMap k v
HM.empty
where parsePrefs :: ByteString -> m [(Text, ProfilePref)]
parsePrefs ByteString
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ProfileParseError
ProfileParseError) forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either FilePath a
parseOnly Parser [(Text, ProfilePref)]
prefsParser ByteString
s
prepareProfile :: MonadBaseControl IO m =>
Profile Firefox -> m (PreparedProfile Firefox)
prepareProfile :: forall (m :: * -> *).
MonadBaseControl IO m =>
Profile Firefox -> m (PreparedProfile Firefox)
prepareProfile Profile {profileFiles :: forall b. Profile b -> HashMap FilePath FilePath
profileFiles = HashMap FilePath FilePath
files, profilePrefs :: forall b. Profile b -> HashMap Text ProfilePref
profilePrefs = HashMap Text ProfilePref
prefs}
= forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ do
FilePath
tmpdir <- IO FilePath
mkTemp
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> (FilePath, FilePath) -> IO ()
installPath FilePath
tmpdir) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
HM.toList forall a b. (a -> b) -> a -> b
$ HashMap FilePath FilePath
files
FilePath -> IO ()
installUserPrefs FilePath
tmpdir
forall (m :: * -> *) a.
MonadBase IO m =>
FilePath -> m (PreparedProfile a)
prepareLoadedProfile_ FilePath
tmpdir
where
installPath :: FilePath -> (FilePath, FilePath) -> IO ()
installPath FilePath
destDir (FilePath
destPath, FilePath
src) = do
let dest :: FilePath
dest = FilePath
destDir FilePath -> FilePath -> FilePath
</> FilePath
destPath
Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
src
if Bool
isDir
then do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dest forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOException -> IO ()
ignoreIOException
(FilePath
_ DS.:/ DirTree ByteString
dir) <- forall a. (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree a)
DS.readDirectoryWithL FilePath -> IO ByteString
LBS.readFile FilePath
src
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO ()
ignoreIOException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void
forall a b. (a -> b) -> a -> b
$ forall a b.
(FilePath -> a -> IO b)
-> AnchoredDirTree a -> IO (AnchoredDirTree b)
DS.writeDirectoryWith FilePath -> ByteString -> IO ()
LBS.writeFile (FilePath
dest forall a. FilePath -> DirTree a -> AnchoredDirTree a
DS.:/ DirTree ByteString
dir)
else do
let dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
dest
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ FilePath
dir) forall a b. (a -> b) -> a -> b
$
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOException -> IO ()
ignoreIOException
FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
dest forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOException -> IO ()
ignoreIOException
where
ignoreIOException :: IOException -> IO ()
ignoreIOException :: IOException -> IO ()
ignoreIOException = forall a. Show a => a -> IO ()
print
installUserPrefs :: FilePath -> IO ()
installUserPrefs FilePath
d = FilePath -> ByteString -> IO ()
LBS.writeFile (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
"user" FilePath -> FilePath -> FilePath
<.> FilePath
"js") ByteString
str
where
str :: ByteString
str = [ByteString] -> ByteString
LBS.concat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, ProfilePref
v) -> [ByteString] -> ByteString
LBS.concat [ ByteString
"user_pref(", forall a. ToJSON a => a -> ByteString
encode Text
k,
ByteString
", ", forall a. ToJSON a => a -> ByteString
encode ProfilePref
v, ByteString
");\n"])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
HM.toList forall a b. (a -> b) -> a -> b
$ HashMap Text ProfilePref
prefs
prepareTempProfile :: MonadBaseControl IO m =>
(Profile Firefox -> Profile Firefox)
-> m (PreparedProfile Firefox)
prepareTempProfile :: forall (m :: * -> *).
MonadBaseControl IO m =>
(Profile Firefox -> Profile Firefox) -> m (PreparedProfile Firefox)
prepareTempProfile Profile Firefox -> Profile Firefox
f = forall (m :: * -> *).
MonadBaseControl IO m =>
Profile Firefox -> m (PreparedProfile Firefox)
prepareProfile forall b c a. (b -> c) -> (a -> b) -> a -> c
. Profile Firefox -> Profile Firefox
f forall a b. (a -> b) -> a -> b
$ Profile Firefox
defaultProfile
prepareLoadedProfile :: MonadBaseControl IO m =>
FilePath
-> (Profile Firefox -> Profile Firefox)
-> m (PreparedProfile Firefox)
prepareLoadedProfile :: forall (m :: * -> *).
MonadBaseControl IO m =>
FilePath
-> (Profile Firefox -> Profile Firefox)
-> m (PreparedProfile Firefox)
prepareLoadedProfile FilePath
path Profile Firefox -> Profile Firefox
f = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Profile Firefox -> Profile Firefox
f (forall (m :: * -> *).
MonadBaseControl IO m =>
FilePath -> m (Profile Firefox)
loadProfile FilePath
path) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadBaseControl IO m =>
Profile Firefox -> m (PreparedProfile Firefox)
prepareProfile
prefsParser :: Parser [(Text, ProfilePref)]
prefsParser :: Parser [(Text, ProfilePref)]
prefsParser = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Parser ByteString b -> Parser ByteString b
padSpaces forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
string ByteString
"user_pref("
Text
k <- Parser ByteString Text
prefKey forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"preference key"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Parser ByteString b -> Parser ByteString b
padSpaces forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
','
ProfilePref
v <- Parser ByteString ProfilePref
prefVal forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"preference value"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Parser ByteString b -> Parser ByteString b
padSpaces forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
string ByteString
");"
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k,ProfilePref
v)
where
prefKey :: Parser ByteString Text
prefKey = Parser ByteString Text
jstring
prefVal :: Parser ByteString ProfilePref
prefVal = do
Value
v <- Parser Value
value'
case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Error FilePath
str -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
str
Success ProfilePref
p -> forall (m :: * -> *) a. Monad m => a -> m a
return ProfilePref
p
padSpaces :: Parser ByteString b -> Parser ByteString b
padSpaces Parser ByteString b
p = Parser ByteString [()]
spaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString b
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString [()]
spaces
spaces :: Parser ByteString [()]
spaces = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString ()
endOfLine forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Char
space forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString FilePath
comment)
where
comment :: Parser ByteString FilePath
comment = Parser ByteString FilePath
inlineComment forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString FilePath
lineComment
lineComment :: Parser ByteString FilePath
lineComment = Char -> Parser Char
char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar Parser ByteString ()
endOfLine
inlineComment :: Parser ByteString FilePath
inlineComment = ByteString -> Parser ByteString
string ByteString
"/*" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (ByteString -> Parser ByteString
string ByteString
"*/")
mkTemp :: IO FilePath
mkTemp :: IO FilePath
mkTemp = do
FilePath
d <- IO FilePath
getTemporaryDirectory
FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
d FilePath
""