diff --git a/package.yaml b/package.yaml index c434d0d..893d3b6 100644 --- a/package.yaml +++ b/package.yaml @@ -72,6 +72,7 @@ library: - zip-archive >= 0.1.1.8 exposed-modules: - Test.WebDriver + - Test.WebDriver.Actions.Internal - Test.WebDriver.Capabilities - Test.WebDriver.Chrome.Extension - Test.WebDriver.Class @@ -87,6 +88,7 @@ library: - Test.WebDriver.Firefox.Profile - Test.WebDriver.Internal - Test.WebDriver.JSON + - Test.WebDriver.JSON.Internal - Test.WebDriver.Monad - Test.WebDriver.Session - Test.WebDriver.Session.History diff --git a/src/Test/WebDriver/Actions/Internal.hs b/src/Test/WebDriver/Actions/Internal.hs new file mode 100644 index 0000000..c75a20f --- /dev/null +++ b/src/Test/WebDriver/Actions/Internal.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.WebDriver.Actions.Internal where + +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import Test.WebDriver.Commands.Internal (Element) +import Test.WebDriver.JSON.Internal (lower1) + +data Actions = Actions + { actionsId :: Text + , actionsType :: ActionsType + , actionsParameters :: Maybe ActionsParameters + , actionsActions :: [Action] + } deriving (Eq, Show) + +data ActionsType = + ActionsPointer + | ActionsKey + | ActionsNone + deriving (Eq, Show) + +data ActionsParameters = ActionsParameters + { paramsPointerType :: Maybe PointerType + } deriving (Eq, Show) + +data Action = Action + { actionType :: ActionType + , actionDurtion :: Maybe Int + , actionX :: Maybe Int + , actionY :: Maybe Int + , actionOrigin :: Maybe MoveOrigin + , actionValue :: Maybe Text + , actionButton :: Maybe MouseButton + } deriving (Eq, Show) + +data PointerType = + PointerMouse + | PointerPen + | PointerTouch + deriving (Eq, Show) + +data MoveOrigin = + OriginViewport + | OriginPointer + | OriginElement Element + deriving (Eq, Show) + +instance ToJSON MoveOrigin where + toJSON OriginViewport = String "viewport" + toJSON OriginPointer = String "pointer" + toJSON (OriginElement e) = toJSON e + +data ActionType = + ActionPause + | ActionKeyUp + | ActionKeyDown + | ActionPointerUp + | ActionPointerDown + | ActionPointerMove + | ActionPointerCancel + | ActionScroll + deriving (Eq, Show) + +-- |A mouse button +data MouseButton = + LeftButton + | MiddleButton + | RightButton + deriving (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON MouseButton where + toJSON = toJSON . fromEnum + +instance FromJSON MouseButton where + parseJSON v = do + n <- parseJSON v + case n :: Integer of + 0 -> return LeftButton + 1 -> return MiddleButton + 2 -> return RightButton + err -> fail $ "Invalid JSON for MouseButton: " ++ show err + +$(deriveToJSON (defaultOptions{constructorTagModifier = lower1 . drop 7}) ''PointerType) +$(deriveToJSON (defaultOptions{constructorTagModifier = lower1 . drop 6}) ''ActionType) +$(deriveToJSON (defaultOptions{constructorTagModifier = lower1 . drop 7}) ''ActionsType) +$(deriveToJSON (defaultOptions{fieldLabelModifier = lower1 . drop 6, omitNothingFields = True}) ''Action) +$(deriveToJSON (defaultOptions{fieldLabelModifier = lower1 . drop 6, omitNothingFields = True}) ''ActionsParameters) +$(deriveToJSON (defaultOptions{fieldLabelModifier = lower1 . drop 7, omitNothingFields = True}) ''Actions) + +pointerMoveAction :: (Int, Int) -> MoveOrigin -> Action +pointerMoveAction (x, y) origin = + Action + { actionType = ActionPointerMove + , actionDurtion = Nothing + , actionX = Just x + , actionY = Just y + , actionOrigin = Just origin + , actionValue = Nothing + , actionButton = Nothing + } + +pointerDownAction :: Action +pointerDownAction = + Action + { actionType = ActionPointerDown + , actionDurtion = Nothing + , actionX = Nothing + , actionY = Nothing + , actionOrigin = Nothing + , actionValue = Nothing + , actionButton = Nothing + } + +pointerUpAction :: Action +pointerUpAction = + Action + { actionType = ActionPointerUp + , actionDurtion = Nothing + , actionX = Nothing + , actionY = Nothing + , actionOrigin = Nothing + , actionValue = Nothing + , actionButton = Nothing + } + +keyDownAction :: Text -> Action +keyDownAction c = + Action + { actionType = ActionKeyDown + , actionDurtion = Nothing + , actionX = Nothing + , actionY = Nothing + , actionOrigin = Nothing + , actionValue = Just c + , actionButton = Nothing + } + +keyUpAction :: Text -> Action +keyUpAction c = + Action + { actionType = ActionKeyUp + , actionDurtion = Nothing + , actionX = Nothing + , actionY = Nothing + , actionOrigin = Nothing + , actionValue = Just c + , actionButton = Nothing + } diff --git a/src/Test/WebDriver/JSON/Internal.hs b/src/Test/WebDriver/JSON/Internal.hs new file mode 100644 index 0000000..5fd3e80 --- /dev/null +++ b/src/Test/WebDriver/JSON/Internal.hs @@ -0,0 +1,7 @@ +module Test.WebDriver.JSON.Internal where + +import qualified Data.Char as C + +lower1 :: String -> String +lower1 [] = [] +lower1 (c:cs) = C.toLower c : cs diff --git a/webdriver.cabal b/webdriver.cabal index 47e4b72..dbcc09b 100644 --- a/webdriver.cabal +++ b/webdriver.cabal @@ -43,6 +43,7 @@ source-repository head library exposed-modules: Test.WebDriver + Test.WebDriver.Actions.Internal Test.WebDriver.Capabilities Test.WebDriver.Chrome.Extension Test.WebDriver.Class @@ -58,6 +59,7 @@ library Test.WebDriver.Firefox.Profile Test.WebDriver.Internal Test.WebDriver.JSON + Test.WebDriver.JSON.Internal Test.WebDriver.Monad Test.WebDriver.Session Test.WebDriver.Session.History