{-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances,
             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
       ( -- *Profiles and profile preferences
         Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..)
         -- * Preferences
       , getPref, addPref, deletePref
         -- * Extensions
       , addExtension, deleteExtension, hasExtension
         -- * Other files and directories
       , addFile, deleteFile, hasFile
         -- * Miscellaneous profile operations
       , unionProfiles, onProfileFiles, onProfilePrefs
         -- *Preparing profiles from disk
       , prepareLoadedProfile_
         -- *Preparing zipped profiles
       , prepareZippedProfile, prepareZipArchive,
         prepareRawZip
         -- *Profile errors
       , ProfileParseError(..)
       ) where

import System.Directory
import System.FilePath hiding (addExtension, hasExtension)
import Codec.Archive.Zip
import Data.Aeson
import Data.Aeson.Types

#if MIN_VERSION_aeson(0,7,0)
import Data.Scientific
#else
import Data.Attoparsec.Number (Number(..))
#endif

import qualified Data.HashMap.Strict as HM
import Data.Text (Text, pack)
import Data.ByteString.Lazy (ByteString)
--import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Base64.Lazy as B64
import qualified Data.Text.Lazy.Encoding as TL


import Data.Fixed
import Data.Ratio
import Data.Int
import Data.Word
import Data.Typeable

import Control.Exception
import Control.Applicative
import Control.Monad.Base

import Prelude -- hides some "unused import" warnings

-- |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 profiles; when a distinction
-- must be made, the phantom type parameter is used to differentiate.
data Profile b = Profile
                 { -- |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.
                   forall b. Profile b -> HashMap FilePath FilePath
profileFiles   :: HM.HashMap FilePath FilePath
                   -- |A map of profile preferences. These are the settings
                   -- found in the profile's prefs.js, and entries found in
                   -- about:config
                 , forall b. Profile b -> HashMap Text ProfilePref
profilePrefs  :: HM.HashMap Text ProfilePref
                 }
               deriving (Profile b -> Profile b -> Bool
forall b. Profile b -> Profile b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Profile b -> Profile b -> Bool
$c/= :: forall b. Profile b -> Profile b -> Bool
== :: Profile b -> Profile b -> Bool
$c== :: forall b. Profile b -> Profile b -> Bool
Eq, Int -> Profile b -> ShowS
forall b. Int -> Profile b -> ShowS
forall b. [Profile b] -> ShowS
forall b. Profile b -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Profile b] -> ShowS
$cshowList :: forall b. [Profile b] -> ShowS
show :: Profile b -> FilePath
$cshow :: forall b. Profile b -> FilePath
showsPrec :: Int -> Profile b -> ShowS
$cshowsPrec :: forall b. Int -> Profile b -> ShowS
Show)

-- |Represents a profile that has been prepared for
-- network transmission. The profile cannot be modified in this form.
newtype PreparedProfile b = PreparedProfile ByteString
  deriving (PreparedProfile b -> PreparedProfile b -> Bool
forall b. PreparedProfile b -> PreparedProfile b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreparedProfile b -> PreparedProfile b -> Bool
$c/= :: forall b. PreparedProfile b -> PreparedProfile b -> Bool
== :: PreparedProfile b -> PreparedProfile b -> Bool
$c== :: forall b. PreparedProfile b -> PreparedProfile b -> Bool
Eq, Int -> PreparedProfile b -> ShowS
forall b. Int -> PreparedProfile b -> ShowS
forall b. [PreparedProfile b] -> ShowS
forall b. PreparedProfile b -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PreparedProfile b] -> ShowS
$cshowList :: forall b. [PreparedProfile b] -> ShowS
show :: PreparedProfile b -> FilePath
$cshow :: forall b. PreparedProfile b -> FilePath
showsPrec :: Int -> PreparedProfile b -> ShowS
$cshowsPrec :: forall b. Int -> PreparedProfile b -> ShowS
Show)

instance FromJSON (PreparedProfile s) where
  parseJSON :: Value -> Parser (PreparedProfile s)
parseJSON Value
v = forall b. ByteString -> PreparedProfile b
PreparedProfile forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TL.encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance ToJSON (PreparedProfile s) where
  toJSON :: PreparedProfile s -> Value
toJSON (PreparedProfile ByteString
s) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TL.decodeUtf8 ByteString
s

-- |A profile preference value. This is the subset of JSON values that excludes
-- arrays, objects, and null.
data ProfilePref = PrefInteger !Integer
                 | PrefDouble  !Double
                 | PrefString  !Text
                 | PrefBool    !Bool
                 deriving (ProfilePref -> ProfilePref -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProfilePref -> ProfilePref -> Bool
$c/= :: ProfilePref -> ProfilePref -> Bool
== :: ProfilePref -> ProfilePref -> Bool
$c== :: ProfilePref -> ProfilePref -> Bool
Eq, Int -> ProfilePref -> ShowS
[ProfilePref] -> ShowS
ProfilePref -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ProfilePref] -> ShowS
$cshowList :: [ProfilePref] -> ShowS
show :: ProfilePref -> FilePath
$cshow :: ProfilePref -> FilePath
showsPrec :: Int -> ProfilePref -> ShowS
$cshowsPrec :: Int -> ProfilePref -> ShowS
Show)

instance ToJSON ProfilePref where
  toJSON :: ProfilePref -> Value
toJSON ProfilePref
v = case ProfilePref
v of
    PrefInteger Integer
i -> forall a. ToJSON a => a -> Value
toJSON Integer
i
    PrefDouble Double
d  -> forall a. ToJSON a => a -> Value
toJSON Double
d
    PrefString Text
s  -> forall a. ToJSON a => a -> Value
toJSON Text
s
    PrefBool  Bool
b   -> forall a. ToJSON a => a -> Value
toJSON Bool
b

instance FromJSON ProfilePref where
  parseJSON :: Value -> Parser ProfilePref
parseJSON (String Text
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> ProfilePref
PrefString Text
s
  parseJSON (Bool Bool
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> ProfilePref
PrefBool Bool
b
#if MIN_VERSION_aeson(0,7,0)
  parseJSON (Number Scientific
s) | Scientific -> Int
base10Exponent Scientific
s forall a. Ord a => a -> a -> Bool
>= Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ProfilePref
PrefInteger (Scientific -> Integer
coefficient Scientific
s forall a. Num a => a -> a -> a
* Integer
10forall a b. (Num a, Integral b) => a -> b -> a
^(Scientific -> Int
base10Exponent Scientific
s))
                       | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> ProfilePref
PrefDouble forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Scientific
s
#else
  parseJSON (Number (I i)) = return $ PrefInteger i
  parseJSON (Number (D d)) = return $ PrefDouble d
#endif
  parseJSON Value
other = forall a. FilePath -> Value -> Parser a
typeMismatch FilePath
"ProfilePref" Value
other

instance Exception ProfileParseError
-- |An error occured while attempting to parse a profile's preference file.
newtype ProfileParseError = ProfileParseError String
                          deriving  (ProfileParseError -> ProfileParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProfileParseError -> ProfileParseError -> Bool
$c/= :: ProfileParseError -> ProfileParseError -> Bool
== :: ProfileParseError -> ProfileParseError -> Bool
$c== :: ProfileParseError -> ProfileParseError -> Bool
Eq, Int -> ProfileParseError -> ShowS
[ProfileParseError] -> ShowS
ProfileParseError -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ProfileParseError] -> ShowS
$cshowList :: [ProfileParseError] -> ShowS
show :: ProfileParseError -> FilePath
$cshow :: ProfileParseError -> FilePath
showsPrec :: Int -> ProfileParseError -> ShowS
$cshowsPrec :: Int -> ProfileParseError -> ShowS
Show, ReadPrec [ProfileParseError]
ReadPrec ProfileParseError
Int -> ReadS ProfileParseError
ReadS [ProfileParseError]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ProfileParseError]
$creadListPrec :: ReadPrec [ProfileParseError]
readPrec :: ReadPrec ProfileParseError
$creadPrec :: ReadPrec ProfileParseError
readList :: ReadS [ProfileParseError]
$creadList :: ReadS [ProfileParseError]
readsPrec :: Int -> ReadS ProfileParseError
$creadsPrec :: Int -> ReadS ProfileParseError
Read, Typeable)

-- |A typeclass to convert types to profile preference values
class ToPref a where
  toPref :: a -> ProfilePref

instance ToPref Text where
  toPref :: Text -> ProfilePref
toPref = Text -> ProfilePref
PrefString

instance ToPref String where
  toPref :: FilePath -> ProfilePref
toPref = forall a. ToPref a => a -> ProfilePref
toPref forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack

instance ToPref Bool where
  toPref :: Bool -> ProfilePref
toPref = Bool -> ProfilePref
PrefBool

instance ToPref Integer where
  toPref :: Integer -> ProfilePref
toPref = Integer -> ProfilePref
PrefInteger

#define I(t) instance ToPref t where toPref = PrefInteger . toInteger

I(Int)
I(Int8)
I(Int16)
I(Int32)
I(Int64)
I(Word)
I(Word8)
I(Word16)
I(Word32)
I(Word64)

instance ToPref Double where
  toPref :: Double -> ProfilePref
toPref = Double -> ProfilePref
PrefDouble

instance ToPref Float where
  toPref :: Float -> ProfilePref
toPref = Double -> ProfilePref
PrefDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

instance (Integral a) => ToPref (Ratio a) where
  toPref :: Ratio a -> ProfilePref
toPref = Double -> ProfilePref
PrefDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

instance (HasResolution r) => ToPref (Fixed r) where
  toPref :: Fixed r -> ProfilePref
toPref = Double -> ProfilePref
PrefDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

instance ToPref ProfilePref where
  toPref :: ProfilePref -> ProfilePref
toPref = forall a. a -> a
id

-- |Retrieve a preference from a profile by key name.
getPref :: Text -> Profile b -> Maybe ProfilePref
getPref :: forall b. Text -> Profile b -> Maybe ProfilePref
getPref Text
k (Profile HashMap FilePath FilePath
_ HashMap Text ProfilePref
m) = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k HashMap Text ProfilePref
m

-- |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 :: forall a b. ToPref a => Text -> a -> Profile b -> Profile b
addPref Text
k a
v Profile b
p = forall b.
Profile b
-> (HashMap Text ProfilePref -> HashMap Text ProfilePref)
-> Profile b
onProfilePrefs Profile b
p forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
k (forall a. ToPref a => a -> ProfilePref
toPref a
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 :: forall b. Text -> Profile b -> Profile b
deletePref Text
k Profile b
p = forall b.
Profile b
-> (HashMap Text ProfilePref -> HashMap Text ProfilePref)
-> Profile b
onProfilePrefs Profile b
p forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
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. Overwrites any file that
-- previously pointed to the same destination
addFile :: FilePath -> FilePath -> Profile b -> Profile b
addFile :: forall b. FilePath -> FilePath -> Profile b -> Profile b
addFile FilePath
src FilePath
dest Profile b
p = forall b.
Profile b
-> (HashMap FilePath FilePath -> HashMap FilePath FilePath)
-> Profile b
onProfileFiles Profile b
p forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert FilePath
dest FilePath
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 :: forall b. FilePath -> Profile b -> Profile b
deleteFile FilePath
path Profile b
prof = forall b.
Profile b
-> (HashMap FilePath FilePath -> HashMap FilePath FilePath)
-> Profile b
onProfileFiles Profile b
prof forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete FilePath
path

-- |Determines if a profile contains the given file, specified as a path
-- relative to the profile directory.
hasFile :: String -> Profile b -> Bool
hasFile :: forall b. FilePath -> Profile b -> Bool
hasFile FilePath
path (Profile HashMap FilePath FilePath
files HashMap Text ProfilePref
_) = FilePath
path forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` HashMap FilePath FilePath
files

-- |Add a new extension to the profile. The file path should refer to
-- a .xpi file or an extension directory on the filesystem.
addExtension :: FilePath -> Profile b -> Profile b
addExtension :: forall b. FilePath -> Profile b -> Profile b
addExtension FilePath
path = forall b. FilePath -> FilePath -> Profile b -> Profile b
addFile FilePath
path (FilePath
"extensions" FilePath -> ShowS
</> FilePath
name)
  where (FilePath
_, FilePath
name) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
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 :: forall b. FilePath -> Profile b -> Profile b
deleteExtension FilePath
name = forall b. FilePath -> Profile b -> Profile b
deleteFile (FilePath
"extensions" FilePath -> ShowS
</> FilePath
name)

-- |Determines if a profile contains the given extension. specified as an
-- .xpi file or directory name
hasExtension :: String -> Profile b -> Bool
hasExtension :: forall b. FilePath -> Profile b -> Bool
hasExtension FilePath
name Profile b
prof = forall b. FilePath -> Profile b -> Bool
hasFile (FilePath
"extensions" FilePath -> ShowS
</> FilePath
name) Profile b
prof


-- |Takes the union of two profiles. This is the union of their 'HashMap'
-- fields.
unionProfiles :: Profile b -> Profile b -> Profile b
unionProfiles :: forall b. Profile b -> Profile b -> Profile b
unionProfiles (Profile HashMap FilePath FilePath
f1 HashMap Text ProfilePref
p1) (Profile HashMap FilePath FilePath
f2 HashMap Text ProfilePref
p2)
  = forall b.
HashMap FilePath FilePath -> HashMap Text ProfilePref -> Profile b
Profile (HashMap FilePath FilePath
f1 forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` HashMap FilePath FilePath
f2) (HashMap Text ProfilePref
p1 forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` HashMap Text ProfilePref
p2)

-- |Modifies the 'profilePrefs' field of a profile.
onProfilePrefs :: Profile b
                  -> (HM.HashMap Text ProfilePref
                      -> HM.HashMap Text ProfilePref)
                  -> Profile b
onProfilePrefs :: forall b.
Profile b
-> (HashMap Text ProfilePref -> HashMap Text ProfilePref)
-> Profile b
onProfilePrefs (Profile HashMap FilePath FilePath
hs HashMap Text ProfilePref
hm) HashMap Text ProfilePref -> HashMap Text ProfilePref
f = forall b.
HashMap FilePath FilePath -> HashMap Text ProfilePref -> Profile b
Profile HashMap FilePath FilePath
hs (HashMap Text ProfilePref -> HashMap Text ProfilePref
f HashMap Text ProfilePref
hm)

-- |Modifies the 'profileFiles' field of a profile
onProfileFiles :: Profile b
                  -> (HM.HashMap FilePath FilePath
                      -> HM.HashMap FilePath FilePath)
                  -> Profile b
onProfileFiles :: forall b.
Profile b
-> (HashMap FilePath FilePath -> HashMap FilePath FilePath)
-> Profile b
onProfileFiles (Profile HashMap FilePath FilePath
ls HashMap Text ProfilePref
hm) HashMap FilePath FilePath -> HashMap FilePath FilePath
f = forall b.
HashMap FilePath FilePath -> HashMap Text ProfilePref -> Profile b
Profile (HashMap FilePath FilePath -> HashMap FilePath FilePath
f HashMap FilePath FilePath
ls) HashMap Text ProfilePref
hm


-- |Efficiently load an existing profile from disk and prepare it for network
-- transmission.
prepareLoadedProfile_ :: MonadBase IO m =>
                        FilePath -> m (PreparedProfile a)
prepareLoadedProfile_ :: forall (m :: * -> *) a.
MonadBase IO m =>
FilePath -> m (PreparedProfile a)
prepareLoadedProfile_ FilePath
path = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ do
  FilePath
oldWd <- IO FilePath
getCurrentDirectory
  FilePath -> IO ()
setCurrentDirectory FilePath
path
  forall a. Archive -> PreparedProfile a
prepareZipArchive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase ([ZipOption] -> Archive -> [FilePath] -> IO Archive
addFilesToArchive [ZipOption
OptRecursive]
              Archive
emptyArchive [FilePath
"."])
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* FilePath -> IO ()
setCurrentDirectory FilePath
oldWd

-- |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 :: forall (m :: * -> *) a.
MonadBase IO m =>
FilePath -> m (PreparedProfile a)
prepareZippedProfile FilePath
path = forall b. ByteString -> PreparedProfile b
prepareRawZip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (FilePath -> IO ByteString
LBS.readFile FilePath
path)

-- |Prepare a zip archive of a profile for network transmission.
prepareZipArchive :: Archive -> PreparedProfile a
prepareZipArchive :: forall a. Archive -> PreparedProfile a
prepareZipArchive = forall b. ByteString -> PreparedProfile b
prepareRawZip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archive -> ByteString
fromArchive

-- |Prepare a ByteString of raw zip data for network transmission
prepareRawZip :: ByteString -> PreparedProfile a
prepareRawZip :: forall b. ByteString -> PreparedProfile b
prepareRawZip = forall b. ByteString -> PreparedProfile b
PreparedProfile forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode