module Test.WebDriver.Common.Profile
(
Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..)
, getPref, addPref, deletePref
, addExtension, deleteExtension, hasExtension
, addFile, deleteFile, hasFile
, unionProfiles, onProfileFiles, onProfilePrefs
, prepareLoadedProfile_
, prepareZippedProfile, prepareZipArchive,
prepareRawZip
, 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.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
data Profile b = Profile
{
profileFiles :: HM.HashMap FilePath FilePath
, profilePrefs :: HM.HashMap Text ProfilePref
}
deriving (Eq, Show)
newtype PreparedProfile b = PreparedProfile ByteString
deriving (Eq, Show)
instance FromJSON (PreparedProfile s) where
parseJSON v = PreparedProfile . TL.encodeUtf8 <$> parseJSON v
instance ToJSON (PreparedProfile s) where
toJSON (PreparedProfile s) = toJSON $ TL.decodeUtf8 s
data ProfilePref = PrefInteger !Integer
| PrefDouble !Double
| PrefString !Text
| PrefBool !Bool
deriving (Eq, Show)
instance ToJSON ProfilePref where
toJSON v = case v of
PrefInteger i -> toJSON i
PrefDouble d -> toJSON d
PrefString s -> toJSON s
PrefBool b -> toJSON b
instance FromJSON ProfilePref where
parseJSON (String s) = return $ PrefString s
parseJSON (Bool b) = return $ PrefBool b
#if MIN_VERSION_aeson(0,7,0)
parseJSON (Number s) | base10Exponent s >= 0 = return $ PrefInteger (coefficient s * 10^(base10Exponent s))
| otherwise = return $ PrefDouble $ realToFrac s
#else
parseJSON (Number (I i)) = return $ PrefInteger i
parseJSON (Number (D d)) = return $ PrefDouble d
#endif
parseJSON other = typeMismatch "ProfilePref" other
instance Exception ProfileParseError
newtype ProfileParseError = ProfileParseError String
deriving (Eq, Show, Read, Typeable)
class ToPref a where
toPref :: a -> ProfilePref
instance ToPref Text where
toPref = PrefString
instance ToPref String where
toPref = toPref . pack
instance ToPref Bool where
toPref = PrefBool
instance ToPref Integer where
toPref = 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 = PrefDouble
instance ToPref Float where
toPref = PrefDouble . realToFrac
instance (Integral a) => ToPref (Ratio a) where
toPref = PrefDouble . realToFrac
instance (HasResolution r) => ToPref (Fixed r) where
toPref = PrefDouble . realToFrac
getPref :: Text -> Profile b -> Maybe ProfilePref
getPref k (Profile _ m) = HM.lookup k m
addPref :: ToPref a => Text -> a -> Profile b -> Profile b
addPref k v p = onProfilePrefs p $ HM.insert k (toPref v)
deletePref :: Text -> Profile b -> Profile b
deletePref k p = onProfilePrefs p $ HM.delete k
addFile :: FilePath -> FilePath -> Profile b -> Profile b
addFile src dest p = onProfileFiles p $ HM.insert dest src
deleteFile :: FilePath -> Profile b -> Profile b
deleteFile path prof = onProfileFiles prof $ HM.delete path
hasFile :: String -> Profile b -> Bool
hasFile path (Profile files _) = path `HM.member` files
addExtension :: FilePath -> Profile b -> Profile b
addExtension path = addFile path ("extensions" </> name)
where (_, name) = splitFileName path
deleteExtension :: String -> Profile b -> Profile b
deleteExtension name = deleteFile ("extensions" </> name)
hasExtension :: String -> Profile b -> Bool
hasExtension name prof = hasFile ("extensions" </> name) prof
unionProfiles :: Profile b -> Profile b -> Profile b
unionProfiles (Profile f1 p1) (Profile f2 p2)
= Profile (f1 `HM.union` f2) (p1 `HM.union` p2)
onProfilePrefs :: Profile b
-> (HM.HashMap Text ProfilePref
-> HM.HashMap Text ProfilePref)
-> Profile b
onProfilePrefs (Profile hs hm) f = Profile hs (f hm)
onProfileFiles :: Profile b
-> (HM.HashMap FilePath FilePath
-> HM.HashMap FilePath FilePath)
-> Profile b
onProfileFiles (Profile ls hm) f = Profile (f ls) hm
prepareLoadedProfile_ :: MonadBase IO m =>
FilePath -> m (PreparedProfile a)
prepareLoadedProfile_ path = liftBase $ do
oldWd <- getCurrentDirectory
setCurrentDirectory path
prepareZipArchive <$>
liftBase (addFilesToArchive [OptRecursive]
emptyArchive ["."])
<* setCurrentDirectory oldWd
prepareZippedProfile :: MonadBase IO m =>
FilePath -> m (PreparedProfile a)
prepareZippedProfile path = prepareRawZip <$> liftBase (LBS.readFile path)
prepareZipArchive :: Archive -> PreparedProfile a
prepareZipArchive = prepareRawZip . fromArchive
prepareRawZip :: ByteString -> PreparedProfile a
prepareRawZip = PreparedProfile . B64.encode