From 8e3918f6df7afd6cf22b18e03e5db5cde0dc4a29 Mon Sep 17 00:00:00 2001 From: Serhii Khoma Date: Thu, 19 Nov 2020 18:50:13 +0200 Subject: [PATCH] Squashed commit of the following: commit 3b7c111d548ed95c5c79b3fddfcb80859ccf0a94 Author: Serhii Khoma Date: Thu Nov 19 18:36:44 2020 +0200 fix: ci commit 1831afa7db467a7f3687e3d991abbb973685d7cd Author: Serhii Khoma Date: Thu Nov 19 18:15:29 2020 +0200 fix: review -> commments and style commit f94fc1a87b5d230c3b8a7673e3f5224d0151b93c Author: Serhii Khoma Date: Thu Nov 19 17:41:22 2020 +0200 fix: review -> return type Lunapark commit 95ba053e15c4fbd780fe60a8136d0f68cf789ffe Author: Serhii Khoma Date: Thu Nov 19 17:36:30 2020 +0200 fix: review -> indentation commit e60fd79658aa14a883f21c7b226e6e63404cc270 Author: Serhii Khoma Date: Thu Nov 19 17:34:32 2020 +0200 fix: review -> rename LunaparkActionsEffect to ActionsEffect commit b3abe292f58ac855e7732e5647aecc64473b6d33 Author: Serhii Khoma Date: Thu Nov 19 17:11:39 2020 +0200 refactor: add comment commit e7428d973c198bbb89d316e1ec2418ad9fdd95c2 Author: Serhii Khoma Date: Thu Nov 19 16:38:53 2020 +0200 fix: review -> fine grain tryAndCache errors commit 89c37e4cd53eb589d15460e362e35304f73d2f4d Author: Serhii Khoma Date: Thu Nov 19 12:12:16 2020 +0200 fix: review -> rename throwLeftJsonDecodeError to rethrowAsJsonDecodeError and remove throwLeftUserError commit 50f546ec7788cc9c23a6aa056b1f3ec358558896 Author: Serhii Khoma Date: Thu Nov 19 12:06:00 2020 +0200 fix: review -> remove test commit 2c254f43e8d12168ef77c793e93793f4a05b5e88 Author: Serhii Khoma Date: Thu Nov 19 12:05:31 2020 +0200 fix: review -> dont export handleAPIError commit 8ec2b5c3c8a8abdc09f4743b7d86de49d66f4dc5 Author: Serhii Khoma Date: Thu Nov 19 11:47:25 2020 +0200 fix: review -> remove extra | commit 49e194e4040ec1425c261d53027aa82a2b8a2ccd Author: Serhii Khoma Date: Wed Nov 18 19:24:48 2020 +0200 feat: remove WithAction and WithLunapark, use rows commit 661bb41941b1ef0afa1a99d6d61246fb79225f5c Author: Serhii Khoma Date: Wed Nov 18 19:04:42 2020 +0200 refactor: remove BaseRun and Lunapark, add LunaparkBaseEffects, LunaparkEffect, LunaparkActionsEffect commit c8dfbf1dce4e5ab82a9e316d14b07c10894627d7 Author: Serhii Khoma Date: Wed Nov 18 13:27:30 2020 +0200 feat: rename post_ to post' to match post_ function from Affjax commit c29e049afedc98bac222ef60333eb4d858b47c7a Author: Serhii Khoma Date: Tue Nov 17 15:01:20 2020 +0200 feat: update npm packages commit 69c22bb9b2f24458cde86b320044089e095b1afc Author: Serhii Khoma Date: Tue Nov 17 14:44:45 2020 +0200 feat: return bower commit 56eb0b4f11d8217d23c4a4751828c0e306966554 Author: Serhii Khoma Date: Mon Nov 16 20:36:00 2020 +0200 feat: printError commit a914049f0f17344329eb6cabd6c64b5d08a4d9fb Author: Serhii Khoma Date: Mon Nov 16 20:34:41 2020 +0200 feat: printError commit 4a680456c4aafd76e0abd09f8b7d6458c8989633 Author: Serhii Khoma Date: Mon Nov 16 19:14:14 2020 +0200 feat: travis -> use spago commit 8ef0769cb0b15690faceeaa45aedd7c770c214a9 Author: Serhii Khoma Date: Mon Nov 16 19:09:15 2020 +0200 feat: remove bower commit 34d1fd8afcacaa2fac56328a64a4b5cf2613c9c7 Author: Serhii Khoma Date: Mon Nov 16 19:09:07 2020 +0200 feat: add spago commit 42428e272e89608f938d88ba425f4276e3d39456 Author: Serhii Khoma Date: Mon Nov 16 19:01:03 2020 +0200 feat: update bower commit 979439bfcfeffef7bd4ec18baa9a8571e8ceffaa Author: Serhii Khoma Date: Mon Nov 16 18:58:57 2020 +0200 feat: update to argonaut 7 and affjax 11 -> run ps-suggest -> fix prev run commit 5b5810458338c64aa630f1ddbd85e7d4b4467387 Author: Serhii Khoma Date: Mon Nov 16 18:51:31 2020 +0200 feat: update to argonaut 7 and affjax 11 -> run ps-suggest commit 19df44771d1a124b3890df266727625833a02b9c Author: Serhii Khoma Date: Mon Nov 16 18:50:42 2020 +0200 feat: update to argonaut 7 and affjax 11 --- .travis.yml | 4 +- bower.json | 4 +- package.json | 14 +-- packages.dhall | 4 + spago.dhall | 15 +++ src/Lunapark.purs | 10 +- src/Lunapark/API.purs | 156 ++++++++++++++++--------------- src/Lunapark/ActionF.purs | 33 +++---- src/Lunapark/Endpoint.purs | 27 ++++-- src/Lunapark/Error.purs | 151 ++++++------------------------ src/Lunapark/LunaparkF.purs | 112 +++++++++++----------- src/Lunapark/Types.purs | 106 ++++++++++----------- src/Lunapark/Utils.purs | 11 ++- src/Lunapark/WebDriverError.purs | 117 +++++++++++++++++++++++ 14 files changed, 414 insertions(+), 350 deletions(-) create mode 100644 packages.dhall create mode 100644 spago.dhall create mode 100644 src/Lunapark/WebDriverError.purs diff --git a/.travis.yml b/.travis.yml index 7c5c3a2..d9628ca 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,8 +4,8 @@ sudo: required node_js: stable install: - npm install - - npm install -g bower - - bower install --production + - npm install -g spago + - spago install script: - npm run -s build after_success: diff --git a/bower.json b/bower.json index f94d9a7..10e85c8 100644 --- a/bower.json +++ b/bower.json @@ -25,8 +25,8 @@ "vendor" ], "dependencies": { - "purescript-affjax": "^9.0.0", - "purescript-argonaut-codecs": "^6.0.0", + "purescript-affjax": "^11.0.0", + "purescript-argonaut-codecs": "^7.0.0", "purescript-argonaut-core": "^5.0.0", "purescript-css": "^4.0.0", "purescript-node-fs-aff": "^6.0.0", diff --git a/package.json b/package.json index 5ea93fa..e1cfefa 100644 --- a/package.json +++ b/package.json @@ -2,16 +2,16 @@ "name": "purescript-lunapark", "private": true, "scripts": { - "build": "pulp build -- --strict --stash", - "build:non-strict": "pulp build", + "build": "spago build --purs-args '--censor-lib --strict'", + "build:non-strict": "spago build", "ide": "purs ide server" }, "license": "Apache-2.0", "dependencies": { - "chromedriver": "^2.37.0", - "pulp": "^12.2.0", - "purescript": "^0.12.3", - "purescript-psa": "^0.7.3", - "xhr2": "^0.1.4" + "chromedriver": "^86.0.0", + "pulp": "^15.0.0", + "purescript": "^0.13.8", + "purescript-psa": "^0.8.0", + "xhr2": "^0.2.0" } } diff --git a/packages.dhall b/packages.dhall new file mode 100644 index 0000000..c9d57c7 --- /dev/null +++ b/packages.dhall @@ -0,0 +1,4 @@ +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20201021/packages.dhall sha256:55ebdbda1bd6ede4d5307fbc1ef19988c80271b4225d833c8d6fb9b6fb1aa6d8 + +in upstream diff --git a/spago.dhall b/spago.dhall new file mode 100644 index 0000000..3b70427 --- /dev/null +++ b/spago.dhall @@ -0,0 +1,15 @@ +{ name = "lunapark" +, dependencies = + [ "argonaut-core" + , "argonaut-codecs" + , "affjax" + , "console" + , "css" + , "effect" + , "node-fs-aff" + , "psci-support" + , "run" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs" ] +} diff --git a/src/Lunapark.purs b/src/Lunapark.purs index a4a5089..2721c92 100644 --- a/src/Lunapark.purs +++ b/src/Lunapark.purs @@ -3,10 +3,12 @@ module Lunapark , module Lunapark.Error , module Lunapark.ActionF , module Lunapark.LunaparkF + , module Lunapark.WebDriverError ) where -import Lunapark.API (Interpreter(..), runInterpreter, BaseRun, HandleLunaparkInput, Lunapark, handleLunapark, init, interpret, interpretW3CActions, jsonWireActions, runLunapark, runLunaparkActions, w3cActions) -import Lunapark.Error (Error, ErrorType(..), fromJson, fromStringCode, toStringCode, unknownError) -import Lunapark.ActionF (ActionF(..), LUNAPARK_ACTIONS, TouchF(..), WithAction, _lunaparkActions, buttonDown, buttonUp, click, doubleClick, doubleTap, flick, liftAction, longTap, moveTo, pause, scroll, sendKeys, tap, touchDown, touchUp) -import Lunapark.LunaparkF (ElementF(..), LUNAPARK, LunaparkF(..), WithLunapark, _lunapark, acceptAlert, addCookie, back, childElement, childElements, clearElement, clickElement, closeWindow, deleteAllCookies, deleteCookie, dismissAlert, elementScreenshot, executeScript, executeScriptAsync, findElement, findElements, forward, fullscreenWindow, getAlertText, getAllCookies, getAttribute, getCookie, getCss, getProperty, getRectangle, getTagName, getText, getTimeouts, getTitle, getUrl, getWindowHandle, getWindowHandles, getWindowRectangle, go, isDisplayed, isEnabled, isSelected, liftLunapark, maximizeWindow, minimizeWindow, performActions, quit, refresh, releaseActions, screenshot, sendAlertText, sendKeysElement, setTimeouts, setWindowRectangle, status, submitElement, switchToFrame, switchToParentFrame, switchToWindow) +import Lunapark.API (Lunapark, Interpreter(..), runInterpreter, BaseEffects, HandleLunaparkInput, handleLunapark, init, interpret, interpretW3CActions, jsonWireActions, runLunapark, runLunaparkActions, w3cActions) +import Lunapark.Error (Error(..), CachingError(..), printError) +import Lunapark.ActionF (ActionF(..), LUNAPARK_ACTIONS, TouchF(..), ActionsEffect, _lunaparkActions, buttonDown, buttonUp, click, doubleClick, doubleTap, flick, liftAction, longTap, moveTo, pause, scroll, sendKeys, tap, touchDown, touchUp) +import Lunapark.LunaparkF (ElementF(..), LUNAPARK, LunaparkF(..), LunaparkEffect, _lunapark, acceptAlert, addCookie, back, childElement, childElements, clearElement, clickElement, closeWindow, deleteAllCookies, deleteCookie, dismissAlert, elementScreenshot, executeScript, executeScriptAsync, findElement, findElements, forward, fullscreenWindow, getAlertText, getAllCookies, getAttribute, getCookie, getCss, getProperty, getRectangle, getTagName, getText, getTimeouts, getTitle, getUrl, getWindowHandle, getWindowHandles, getWindowRectangle, go, isDisplayed, isEnabled, isSelected, liftLunapark, maximizeWindow, minimizeWindow, performActions, quit, refresh, releaseActions, screenshot, sendAlertText, sendKeysElement, setTimeouts, setWindowRectangle, status, submitElement, switchToFrame, switchToParentFrame, switchToWindow) +import Lunapark.WebDriverError (WebDriverError, WebDriverErrorType(..), fromJson, fromStringCode, toStringCode) diff --git a/src/Lunapark/API.purs b/src/Lunapark/API.purs index c1dc2e5..1826909 100644 --- a/src/Lunapark/API.purs +++ b/src/Lunapark/API.purs @@ -22,20 +22,25 @@ import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Class (liftEffect) import Effect.Ref as Ref import Foreign.Object as FO -import Lunapark.ActionF (_lunaparkActions, LUNAPARK_ACTIONS, ActionF(..), TouchF(..)) +import Lunapark.ActionF (_lunaparkActions, ActionF(..), TouchF(..), ActionsEffect) import Lunapark.Endpoint as LP import Lunapark.Error as LE -import Lunapark.LunaparkF (_lunapark, LUNAPARK, ElementF(..), LunaparkF(..), performActions, findElement) +import Lunapark.LunaparkF (_lunapark, ElementF(..), LunaparkF(..), LunaparkEffect, performActions, findElement) import Lunapark.Types as LT -import Lunapark.Utils (liftAndRethrow, throwLeft, catch) +import Lunapark.Utils (liftAndRethrow, rethrowAsJsonDecodeError, catch) import Node.Buffer as B import Node.FS.Aff as FS +import Run (Run) import Run as R import Run.Except (EXCEPT) +import Type.Row (type (+)) +import Run.Except as RE -newtype Interpreter r = Interpreter (Lunapark r ~> BaseRun r) +type Lunapark r a = Run (BaseEffects + LunaparkEffect + ActionsEffect + r) a -runInterpreter ∷ ∀ r. Interpreter r → Lunapark r ~> BaseRun r +newtype Interpreter r = Interpreter (Run (BaseEffects + LunaparkEffect + ActionsEffect + r) ~> Run (BaseEffects r)) + +runInterpreter ∷ ∀ r. Interpreter r → Run (BaseEffects + LunaparkEffect + ActionsEffect + r) ~> Run (BaseEffects r) runInterpreter (Interpreter f) = f init @@ -54,7 +59,7 @@ init uri caps = do let sessionResponse = do sessObj ← res - lmap LE.unknownError $ LT.decodeCreateSessionResponse sessObj + lmap LE.JsonDecodeError $ LT.decodeCreateSessionResponse sessObj T.for sessionResponse \{ session, capabilities } → do timeoutsRef ← @@ -88,24 +93,24 @@ init uri caps = do interpret ∷ ∀ r . HandleLunaparkInput - → Lunapark r - ~> BaseRun r + → Run (BaseEffects + LunaparkEffect + ActionsEffect + r ) + ~> Run (BaseEffects r) interpret input = runLunapark input <<< runLunaparkActions input - -type Lunapark r = BaseRun (lunapark ∷ LUNAPARK, lunaparkActions ∷ LUNAPARK_ACTIONS|r) - -type BaseRun r = R.Run +type BaseEffects r = ( except ∷ EXCEPT LE.Error , aff ∷ R.AFF , effect ∷ R.EFFECT | r) -runLunapark ∷ ∀ r. HandleLunaparkInput → BaseRun (lunapark ∷ LUNAPARK|r) ~> BaseRun r +runLunapark ∷ ∀ r. HandleLunaparkInput → Run (BaseEffects + LunaparkEffect + r) ~> Run (BaseEffects r) runLunapark input = do R.interpretRec (R.on _lunapark (handleLunapark input) R.send) -runLunaparkActions ∷ ∀ r. HandleLunaparkInput → Lunapark r ~> BaseRun (lunapark ∷ LUNAPARK|r) +runLunaparkActions + ∷ ∀ r. HandleLunaparkInput + → Run (BaseEffects + LunaparkEffect + ActionsEffect + r ) + ~> Run (BaseEffects + LunaparkEffect + r) runLunaparkActions input | input.actionsEnabled = interpretW3CActions Nil | otherwise = R.interpretRec (R.on _lunaparkActions (jsonWireActions input) R.send) @@ -113,8 +118,8 @@ runLunaparkActions input interpretW3CActions ∷ ∀ r . List LT.ActionSequence - → Lunapark r - ~> BaseRun (lunapark ∷ LUNAPARK|r) + → Run (BaseEffects + LunaparkEffect + ActionsEffect + r ) + ~> Run (BaseEffects + LunaparkEffect + r ) interpretW3CActions acc as = case R.peel as of Left la → case tag la of Left a → w3cActions acc interpretW3CActions a @@ -130,11 +135,11 @@ w3cActions ∷ ∀ r a . List LT.ActionSequence → ( List LT.ActionSequence - → Lunapark r - ~> BaseRun (lunapark ∷ LUNAPARK|r) + → Run (BaseEffects + LunaparkEffect + ActionsEffect + r ) + ~> Run (BaseEffects + LunaparkEffect + r) ) - → ActionF (Lunapark r a) - → BaseRun (lunapark ∷ LUNAPARK|r) a + → ActionF (Run (BaseEffects + LunaparkEffect + ActionsEffect + r ) a) + → Run (BaseEffects + LunaparkEffect + r) a w3cActions acc loop = case _ of Click btn next → let seq = [ LT.pointerDown btn, LT.pointerUp btn ] @@ -219,7 +224,7 @@ type HandleLunaparkInput = , actionsEnabled ∷ Boolean } -jsonWireActions ∷ ∀ r. HandleLunaparkInput → ActionF ~> BaseRun (lunapark ∷ LUNAPARK|r) +jsonWireActions ∷ ∀ r. HandleLunaparkInput → ActionF ~> Run (BaseEffects + LunaparkEffect + r) jsonWireActions inp = case _ of Click btn next → do _ ← post (LP.Click : Nil) (LT.encodeButton btn) @@ -232,7 +237,7 @@ jsonWireActions inp = case _ of pure next DoubleClick btn next → do _ ← case btn of - LT.LeftBtn → post_ (LP.DoubleClick : Nil) + LT.LeftBtn → post' (LP.DoubleClick : Nil) other → do _ ← post (LP.Click : Nil) (LT.encodeButton btn) post (LP.Click : Nil) (LT.encodeButton btn) @@ -253,16 +258,16 @@ jsonWireActions inp = case _ of pure next InTouch tch → case tch of Tap next → do - _ ← post_ (LP.Touch : LP.Click : Nil) + _ ← post' (LP.Touch : LP.Click : Nil) pure next TouchDown next → do - _ ← post_ (LP.Touch : LP.Down : Nil) + _ ← post' (LP.Touch : LP.Down : Nil) pure next TouchUp next → do - _ ← post_ (LP.Touch : LP.Up : Nil) + _ ← post' (LP.Touch : LP.Up : Nil) pure next LongClick next → do - _ ← post_ (LP.Touch : LP.LongClick : Nil) + _ ← post' (LP.Touch : LP.LongClick : Nil) pure next Flick move next → do element ← case move.origin of @@ -281,23 +286,23 @@ jsonWireActions inp = case _ of _ ← post (LP.Touch : LP.Scroll : Nil) (LT.encodeMoveToRequest req) pure next DoubleTap next → do - _ ← post_ (LP.Touch : LP.DoubleClick : Nil) + _ ← post' (LP.Touch : LP.DoubleClick : Nil) pure next where post a b = liftAndRethrow $ LP.post inp.uri (inSession : a) b - post_ a = liftAndRethrow $ LP.post_ inp.uri (inSession : a) + post' a = liftAndRethrow $ LP.post' inp.uri (inSession : a) inSession ∷ LP.EndpointPart inSession = LP.InSession inp.session -handleLunapark ∷ ∀ r. HandleLunaparkInput → LunaparkF ~> BaseRun r +handleLunapark ∷ ∀ r. HandleLunaparkInput → LunaparkF ~> Run (BaseEffects r) handleLunapark inp = case _ of Quit next → do _ ← delete $ inSession : Nil pure next Status cont → do res ← get $ LP.Status : Nil - ss ← throwLeft $ LT.decodeServerStatus res + ss ← rethrowAsJsonDecodeError $ LT.decodeServerStatus res pure $ cont ss GetTimeouts cont → do res ← R.liftEffect $ Ref.read inp.timeoutsRef @@ -314,31 +319,31 @@ handleLunapark inp = case _ of pure next GetUrl cont → do res ← get $ inSession : LP.Url : Nil - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res Back next → do - _ ← post_ (inSession : LP.Back : Nil) + _ ← post' (inSession : LP.Back : Nil) pure next Forward next → do - _ ← post_ (inSession : LP.Forward : Nil) + _ ← post' (inSession : LP.Forward : Nil) pure next Refresh next → do - _ ← post_ (inSession : LP.Refresh : Nil) + _ ← post' (inSession : LP.Refresh : Nil) pure next GetTitle cont → do res ← get (inSession : LP.Title : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res GetWindowHandle cont → do res ← tryAndCache "get window handle" [ get (inSession : LP.Window : Nil) , get (inSession : LP.WindowHandle : Nil) ] - map cont $ throwLeft $ LT.decodeWindowHandle res + map cont $ rethrowAsJsonDecodeError $ LT.decodeWindowHandle res GetWindowHandles cont → do res ← tryAndCache "get window handles" [ get (inSession : LP.Window : LP.Handles : Nil) , get (inSession : LP.WindowHandles : Nil) ] - map cont $ throwLeft $ T.traverse LT.decodeWindowHandle =<< J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ T.traverse LT.decodeWindowHandle =<< J.decodeJson res CloseWindow next → do _ ← delete (inSession : LP.Window : Nil) pure next @@ -349,15 +354,15 @@ handleLunapark inp = case _ of _ ← post (inSession : LP.Frame : Nil) (LT.encodeFrameId fid) pure next SwitchToParentFrame next → do - _ ← post_ (inSession : LP.Frame : LP.Parent : Nil) + _ ← post' (inSession : LP.Frame : LP.Parent : Nil) pure next GetWindowRectangle cont → do res ← tryAndCache "get window rectangle" [ do res ← get (inSession : LP.Window : LP.Rect : Nil) - throwLeft $ LT.decodeRectangle res + rethrowAsJsonDecodeError $ LT.decodeRectangle res , do position ← get (inSession : LP.Window : LP.Position : Nil) size ← get (inSession : LP.Window : LP.Size : Nil) - throwLeft $ LT.decodeRectangleLegacy { position, size } + rethrowAsJsonDecodeError $ LT.decodeRectangleLegacy { position, size } ] pure $ cont res SetWindowRectangle r next → do @@ -369,13 +374,13 @@ handleLunapark inp = case _ of ] pure next MaximizeWindow next → do - _ ← post_ (inSession : LP.Window : LP.Maximize : Nil) + _ ← post' (inSession : LP.Window : LP.Maximize : Nil) pure next MinimizeWindow next → do - _ ← post_ (inSession : LP.Window : LP.Minimize : Nil) + _ ← post' (inSession : LP.Window : LP.Minimize : Nil) pure next FullscreenWindow next → do - _ ← post_ (inSession : LP.Window : LP.Fullscreen : Nil) + _ ← post' (inSession : LP.Window : LP.Fullscreen : Nil) pure next ExecuteScript script cont → do map cont $ tryAndCache "execute script" @@ -389,10 +394,10 @@ handleLunapark inp = case _ of ] GetAllCookies cont → do res ← get (inSession : LP.Cookies : Nil) - map cont $ throwLeft $ T.traverse LT.decodeCookie =<< J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ T.traverse LT.decodeCookie =<< J.decodeJson res GetCookie name cont → do res ← get (inSession : LP.Cookie name : Nil) - map cont $ throwLeft $ LT.decodeCookie res + map cont $ rethrowAsJsonDecodeError $ LT.decodeCookie res DeleteAllCookies next → do _ ← delete (inSession : LP.Cookies : Nil) pure next @@ -404,14 +409,14 @@ handleLunapark inp = case _ of pure next DismissAlert next → do _ ← tryAndCache "dismiss alert" - [ post_ (inSession : LP.Alert : LP.Dismiss : Nil) - , post_ (inSession : LP.DismissAlert : Nil) + [ post' (inSession : LP.Alert : LP.Dismiss : Nil) + , post' (inSession : LP.DismissAlert : Nil) ] pure next AcceptAlert next → do _ ← tryAndCache "accept alert" - [ post_ (inSession : LP.Alert : LP.Accept : Nil) - , post_ (inSession : LP.AcceptAlert : Nil) + [ post' (inSession : LP.Alert : LP.Accept : Nil) + , post' (inSession : LP.AcceptAlert : Nil) ] pure next GetAlertText cont → do @@ -419,7 +424,7 @@ handleLunapark inp = case _ of [ get (inSession : LP.Alert : LP.Text : Nil) , get (inSession : LP.AlertText : Nil) ] - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res SendAlertText str next → do _ ← tryAndCache "send alert text" [ post (inSession : LP.Alert : LP.Text : Nil) (LT.encodeSendKeysRequest str) @@ -428,19 +433,19 @@ handleLunapark inp = case _ of pure next Screenshot fp next → do res ← get (inSession : LP.Screenshot : Nil) - screenshotPack ← throwLeft $ LT.decodeScreenshot res + screenshotPack ← rethrowAsJsonDecodeError $ LT.decodeScreenshot res buffer ← R.liftEffect $ B.fromString screenshotPack.content screenshotPack.encoding R.liftAff $ FS.writeFile fp buffer pure next FindElement loc cont → do res ← post (inSession : LP.Element : Nil) (LT.encodeLocator loc) - map cont $ throwLeft $ LT.decodeElement res + map cont $ rethrowAsJsonDecodeError $ LT.decodeElement res FindElements loc cont → do res ← post (inSession : LP.Elements : Nil) (LT.encodeLocator loc) - map cont $ throwLeft $ T.traverse LT.decodeElement =<< J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ T.traverse LT.decodeElement =<< J.decodeJson res GetActiveElement cont → do res ← get (inSession : LP.Element : LP.Active : Nil) - map cont $ throwLeft $ LT.decodeElement res + map cont $ rethrowAsJsonDecodeError $ LT.decodeElement res PerformActions req next → do when inp.actionsEnabled $ void $ post @@ -455,53 +460,53 @@ handleLunapark inp = case _ of in case elF of ChildElement loc cont → do res ← post (inSession : inElement : LP.Element : Nil) (LT.encodeLocator loc) - map cont $ throwLeft $ LT.decodeElement res + map cont $ rethrowAsJsonDecodeError $ LT.decodeElement res ChildElements loc cont → do res ← post (inSession : inElement : LP.Elements : Nil) (LT.encodeLocator loc) - map cont $ throwLeft $ T.traverse LT.decodeElement =<< J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ T.traverse LT.decodeElement =<< J.decodeJson res ScreenshotEl fp next → do res ← get (inSession : inElement : LP.Screenshot : Nil) - screenshotPack ← throwLeft $ LT.decodeScreenshot res + screenshotPack ← rethrowAsJsonDecodeError $ LT.decodeScreenshot res buffer ← R.liftEffect $ B.fromString screenshotPack.content screenshotPack.encoding R.liftAff $ FS.writeFile fp buffer pure next IsSelected cont → do res ← get (inSession : inElement : LP.Selected : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res GetAttribute attr cont → do res ← get (inSession : inElement : LP.Attribute attr : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res GetProperty prop cont → do map cont $ get (inSession : inElement : LP.Property prop : Nil) GetCss css cont → do res ← get (inSession : inElement : LP.CssValue css : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res GetText cont → do res ← get (inSession : inElement : LP.Text : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res GetTagName cont → do res ← get (inSession : inElement : LP.Name : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res GetRectangle cont → map cont $ tryAndCache "get element rectangle" [ do res ← get (inSession : inElement : LP.Rect : Nil) - throwLeft $ LT.decodeRectangle res + rethrowAsJsonDecodeError $ LT.decodeRectangle res , do position ← get (inSession : inElement : LP.Position : Nil) size ← get (inSession : inElement : LP.Size : Nil) - throwLeft $ LT.decodeRectangleLegacy { position, size } + rethrowAsJsonDecodeError $ LT.decodeRectangleLegacy { position, size } ] IsEnabled cont → do res ← get (inSession : inElement : LP.Enabled : Nil) - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res ClickEl next → do _ ← tryAndCache "chromedriver75 update clickElement" - [ post_ (inSession : inElement : LP.Click : Nil) + [ post' (inSession : inElement : LP.Click : Nil) , post (inSession : inElement : LP.Click : Nil) $ LT.encodeElement el ] pure next ClearEl next → do _ ← tryAndCache "chromedriver75 update clearElement" - [ post_ (inSession : inElement : LP.Clear : Nil) + [ post' (inSession : inElement : LP.Clear : Nil) , post (inSession : inElement : LP.Click : Nil) $ LT.encodeElement el ] pure next @@ -521,10 +526,10 @@ handleLunapark inp = case _ of } handleLunapark inp $ ExecuteScript script identity ] - map cont $ throwLeft $ J.decodeJson res + map cont $ rethrowAsJsonDecodeError $ J.decodeJson res Submit next → do _ ← tryAndCache "chromedriver75 update submit form" - [ post_ (inSession : inElement : LP.Submit : Nil) + [ post' (inSession : inElement : LP.Submit : Nil) , post (inSession: inElement : LP.Submit : Nil) $ LT.encodeElement el ] pure next @@ -533,18 +538,17 @@ handleLunapark inp = case _ of delete a = liftAndRethrow $ LP.delete inp.uri a post a b = liftAndRethrow $ LP.post inp.uri a b get a = liftAndRethrow $ LP.get inp.uri a - post_ a = liftAndRethrow $ LP.post_ inp.uri a + post' a = liftAndRethrow $ LP.post' inp.uri a - tryAndCache ∷ ∀ a. String → Array (BaseRun r a) → BaseRun r a + -- | It caches an index of an action that is valid for current webdriver implementation. + -- | So you don't need to search correct one by tring them each time + tryAndCache ∷ ∀ a. String → Array (Run (BaseEffects r) a) → Run (BaseEffects r) a tryAndCache key actions = do - let emptyCases = throwLeft $ Left $ "No valid cases for " <> key <> " caching" - let incorrectCache = throwLeft $ Left $ "Fallback for " <> key <> " error" - mp ← R.liftEffect $ Ref.read inp.requestMapRef case Map.lookup key mp of Just ix → case A.index actions ix of Just action → action - Nothing → incorrectCache + Nothing → RE.throw $ LE.CachingError $ LE.IncorrectCache key Nothing → let go ix acc act = @@ -554,7 +558,7 @@ handleLunapark inp = case _ of pure a in catch try' \_ → acc in - FI.foldlWithIndex go emptyCases actions + FI.foldlWithIndex go (RE.throw $ LE.CachingError $ LE.EmptyCases key) actions inSession ∷ LP.EndpointPart inSession = LP.InSession inp.session diff --git a/src/Lunapark/ActionF.purs b/src/Lunapark/ActionF.purs index b092646..a85319a 100644 --- a/src/Lunapark/ActionF.purs +++ b/src/Lunapark/ActionF.purs @@ -5,6 +5,7 @@ import Prelude import Data.Symbol (SProxy(..)) import Data.Time.Duration (Milliseconds) import Lunapark.Types as LT +import Run (Run) import Run as R @@ -32,49 +33,49 @@ derive instance functorTouchF ∷ Functor TouchF _lunaparkActions = SProxy ∷ SProxy "lunaparkActions" type LUNAPARK_ACTIONS = R.FProxy ActionF -type WithAction r = R.Run (lunaparkActions ∷ LUNAPARK_ACTIONS|r) Unit +type ActionsEffect r = ( lunaparkActions ∷ LUNAPARK_ACTIONS | r ) -liftAction ∷ ∀ r. ActionF Unit → WithAction r +liftAction ∷ ∀ r. ActionF Unit → Run (ActionsEffect r) Unit liftAction = R.lift _lunaparkActions -click ∷ ∀ r. LT.Button → WithAction r +click ∷ ∀ r. LT.Button → Run (ActionsEffect r) Unit click btn = liftAction $ Click btn unit -buttonDown ∷ ∀ r. LT.Button → WithAction r +buttonDown ∷ ∀ r. LT.Button → Run (ActionsEffect r) Unit buttonDown btn = liftAction $ ButtonDown btn unit -buttonUp ∷ ∀ r. LT.Button → WithAction r +buttonUp ∷ ∀ r. LT.Button → Run (ActionsEffect r) Unit buttonUp btn = liftAction $ ButtonUp btn unit -doubleClick ∷ ∀ r. LT.Button → WithAction r +doubleClick ∷ ∀ r. LT.Button → Run (ActionsEffect r) Unit doubleClick btn = liftAction $ DoubleClick btn unit -sendKeys ∷ ∀ r. String → WithAction r +sendKeys ∷ ∀ r. String → Run (ActionsEffect r) Unit sendKeys txt = liftAction $ SendKeys txt unit -moveTo ∷ ∀ r. LT.PointerMove → WithAction r +moveTo ∷ ∀ r. LT.PointerMove → Run (ActionsEffect r) Unit moveTo move = liftAction $ MoveTo move unit -pause ∷ ∀ r. Milliseconds → WithAction r +pause ∷ ∀ r. Milliseconds → Run (ActionsEffect r) Unit pause ms = liftAction $ Pause ms unit -tap ∷ ∀ r. WithAction r +tap ∷ ∀ r. Run (ActionsEffect r) Unit tap = liftAction $ InTouch $ Tap unit -touchDown ∷ ∀ r. WithAction r +touchDown ∷ ∀ r. Run (ActionsEffect r) Unit touchDown = liftAction $ InTouch $ TouchDown unit -touchUp ∷ ∀ r. WithAction r +touchUp ∷ ∀ r. Run (ActionsEffect r) Unit touchUp = liftAction $ InTouch $ TouchUp unit -longTap ∷ ∀ r. WithAction r +longTap ∷ ∀ r. Run (ActionsEffect r) Unit longTap = liftAction $ InTouch $ LongClick unit -flick ∷ ∀ r. LT.PointerMove → WithAction r +flick ∷ ∀ r. LT.PointerMove → Run (ActionsEffect r) Unit flick move = liftAction $ InTouch $ Flick move unit -scroll ∷ ∀ r. LT.PointerMove → WithAction r +scroll ∷ ∀ r. LT.PointerMove → Run (ActionsEffect r) Unit scroll move = liftAction $ InTouch $ Scroll move unit -doubleTap ∷ ∀ r. WithAction r +doubleTap ∷ ∀ r. Run (ActionsEffect r) Unit doubleTap = liftAction $ InTouch $ DoubleTap unit diff --git a/src/Lunapark/Endpoint.purs b/src/Lunapark/Endpoint.purs index 32b7492..91eb6bb 100644 --- a/src/Lunapark/Endpoint.purs +++ b/src/Lunapark/Endpoint.purs @@ -3,7 +3,14 @@ -- | So, to have something like `/session/:sessId/element/:elId/doubleclick` we have -- | `InSession sessId : InElement elId : DoubleClick : Nil` -- | This is not as typesafe as it could be, but at least it saves from typos. -module Lunapark.Endpoint where +module Lunapark.Endpoint + ( delete + , get + , post + , post' + , EndpointPart(..) + ) + where import Prelude @@ -23,6 +30,7 @@ import Data.Newtype (un) import Effect.Aff (Aff) import Lunapark.Error as LE import Lunapark.Types as LT +import Lunapark.WebDriverError as LWE data EndpointPart = Session @@ -169,23 +177,24 @@ printPart = case _ of Flick → "flick" handleAPIError - ∷ N.Response (Either N.ResponseFormatError Json) + ∷ Either N.Error (N.Response Json) → Either LE.Error Json -handleAPIError r = case r.status of - StatusCode 200 → lmap LE.unknownError do - obj ← J.decodeJson =<< lmap N.printResponseFormatError r.body +handleAPIError (Left error) = Left $ LE.AffjaxError error +handleAPIError (Right r) = case r.status of + StatusCode 200 → lmap LE.JsonDecodeError do + obj ← J.decodeJson r.body obj J..: "value" code → - Left $ either (LE.unknownError <<< N.printResponseFormatError) LE.fromJson r.body + Left $ either LE.JsonDecodeError LE.WebDriverError $ LWE.fromJson r.body get ∷ String → Endpoint → Aff (Either LE.Error Json) get uri ep = map handleAPIError $ N.get NR.json (uri <> print ep) post ∷ String → Endpoint → Json → Aff (Either LE.Error Json) -post uri ep obj = map handleAPIError $ N.post NR.json (uri <> print ep) $ NQ.json obj +post uri ep obj = map handleAPIError $ N.post NR.json (uri <> print ep) $ Just (NQ.json obj) -post_ ∷ String → Endpoint → Aff (Either LE.Error Json) -post_ uri ep = map handleAPIError $ N.post' NR.json (uri <> print ep) Nothing +post' ∷ String → Endpoint → Aff (Either LE.Error Json) +post' uri ep = map handleAPIError $ N.post NR.json (uri <> print ep) Nothing delete ∷ String → Endpoint → Aff (Either LE.Error Json) delete uri ep = map handleAPIError $ N.delete NR.json (uri <> print ep) diff --git a/src/Lunapark/Error.purs b/src/Lunapark/Error.purs index 7f7a007..08bc034 100644 --- a/src/Lunapark/Error.purs +++ b/src/Lunapark/Error.purs @@ -1,123 +1,34 @@ module Lunapark.Error where import Prelude - -import Data.Argonaut.Core (Json) as J -import Data.Argonaut.Decode.Combinators ((.:)) as J -import Data.Argonaut.Decode.Class (decodeJson) as J -import Data.Either (Either(..), either) - -data ErrorType - = ElementClickIntercepted - | ElementNotSelectable - | ElementNotInteractable - | InsecureCertificate - | InvalidArgument - | InvalidCookieDomain - | InvalidCoordinates - | InvalidElementState - | InvalidSelector - | InvalidSessionId - | JavaScriptError - | MoveTargetOutOfBounds - | NoSuchAlert - | NoSuchCookie - | NoSuchElement - | NoSuchFrame - | NoSuchWindow - | ScriptTimeout - | SessionNotCreated - | StaleElementReference - | Timeout - | UnableToSetCookie - | UnableToCaptureScreen - | UnexpectedAlertOpen - | UnknownCommand - | UnknownError - | UnknownMethod - | UnsupportedOperation - -fromStringCode ∷ String → Either String ErrorType -fromStringCode = case _ of - "element click intercepted" → Right ElementClickIntercepted - "element not selectable" → Right ElementNotSelectable - "element not interactable" → Right ElementNotInteractable - "insecure certificate" → Right InsecureCertificate - "invalid argument" → Right InvalidArgument - "invalid cookie domain" → Right InvalidCookieDomain - "invalid coordinates" → Right InvalidCoordinates - "invalid element state" → Right InvalidElementState - "invalid selector" → Right InvalidSelector - "invalid session id" → Right InvalidSessionId - "javascript error" → Right JavaScriptError - "move target out of bounds" → Right MoveTargetOutOfBounds - "no such alert" → Right NoSuchAlert - "no such cookie" → Right NoSuchCookie - "no such element" → Right NoSuchElement - "no such frame" → Right NoSuchFrame - "no such window" → Right NoSuchWindow - "script timeout" → Right ScriptTimeout - "session not created" → Right SessionNotCreated - "stale element reference" → Right StaleElementReference - "timeout" → Right Timeout - "unable to set cookie" → Right UnableToSetCookie - "unable to capture screen" → Right UnableToCaptureScreen - "unexpected alert open" → Right UnexpectedAlertOpen - "unknown command" → Right UnknownCommand - "unknown error" → Right UnknownError - "unknown method" → Right UnknownMethod - "unsupported operation" → Right UnsupportedOperation - s → Left s - -toStringCode ∷ ErrorType → String -toStringCode = case _ of - ElementClickIntercepted → "element click intercepted" - ElementNotSelectable → "element not selectable" - ElementNotInteractable → "element not interactable" - InsecureCertificate → "insecure certificate" - InvalidArgument → "invalid argument" - InvalidCookieDomain → "invalid cookie domain" - InvalidCoordinates → "invalid coordinates" - InvalidElementState → "invalid element state" - InvalidSelector → "invalid selector" - InvalidSessionId → "invalid session id" - JavaScriptError → "javascript error" - MoveTargetOutOfBounds → "move target out of bounds" - NoSuchAlert → "no such alert" - NoSuchCookie → "no such cookie" - NoSuchElement → "no such element" - NoSuchFrame → "no such frame" - NoSuchWindow → "no such window" - ScriptTimeout → "script timeout" - SessionNotCreated → "session not created" - StaleElementReference → "stale element reference" - Timeout → "timeout" - UnableToSetCookie → "unable to set cookie" - UnableToCaptureScreen → "unable to capture screen" - UnexpectedAlertOpen → "unexpected alert open" - UnknownCommand → "unknown command" - UnknownError → "unknown error" - UnknownMethod → "unknown method" - UnsupportedOperation → "unsupported operation" - -type Error = - { error ∷ ErrorType - , message ∷ String - , stacktrace ∷ String - } - -fromJson ∷ J.Json → Error -fromJson js = either unknownError identity do - obj ← J.decodeJson js - value ← obj J..: "value" - error ← fromStringCode =<< value J..: "error" - message ← value J..: "message" - stacktrace ← value J..: "stacktrace" - pure { error, message, stacktrace } - -unknownError ∷ String → Error -unknownError message = - { error: UnknownError - , message - , stacktrace: "" - } +import Affjax as N +import Lunapark.WebDriverError as LWE +import Data.Argonaut.Decode (JsonDecodeError, printJsonDecodeError) as J + +data CachingError + = EmptyCases String + | IncorrectCache String + +data Error + = JsonDecodeError J.JsonDecodeError + | WebDriverError LWE.WebDriverError + | AffjaxError N.Error + | CachingError CachingError + +printError ∷ Error → String +printError = case _ of + JsonDecodeError jsonDecodeError → + J.printJsonDecodeError jsonDecodeError + WebDriverError webdriverError → + "Response with error message:\n" + <> " error type: " <> LWE.toStringCode webdriverError.error <> "\n" + <> " message: " <> webdriverError.message <> "\n" + <> " stacktrace: " <> webdriverError.stacktrace + AffjaxError affjaxError → + N.printError affjaxError + CachingError cachingError → + "Error during caching:\n " <> printCachingError cachingError + where + printCachingError = case _ of + EmptyCases key → "There is no working implementation for " <> key <> " action." + IncorrectCache key → "Trying another implementation for " <> key <> " action." diff --git a/src/Lunapark/LunaparkF.purs b/src/Lunapark/LunaparkF.purs index 8132ec3..a9cabb4 100644 --- a/src/Lunapark/LunaparkF.purs +++ b/src/Lunapark/LunaparkF.purs @@ -5,6 +5,7 @@ import Prelude import Data.Argonaut.Core as J import Data.Symbol (SProxy(..)) import Lunapark.Types as LT +import Run (Run) import Run as R data LunaparkF a @@ -71,167 +72,166 @@ derive instance functorElementF ∷ Functor ElementF _lunapark = SProxy ∷ SProxy "lunapark" type LUNAPARK = R.FProxy LunaparkF -type WithLunapark r a = R.Run (lunapark ∷ LUNAPARK|r) a +type LunaparkEffect r = ( lunapark ∷ LUNAPARK | r ) - -liftLunapark ∷ ∀ a r. LunaparkF a → WithLunapark r a +liftLunapark ∷ ∀ a r. LunaparkF a → Run (LunaparkEffect r) a liftLunapark = R.lift _lunapark -quit ∷ ∀ r. WithLunapark r Unit +quit ∷ ∀ r. Run (LunaparkEffect r) Unit quit = liftLunapark $ Quit unit -status ∷ ∀ r. WithLunapark r LT.ServerStatus +status ∷ ∀ r. Run (LunaparkEffect r) LT.ServerStatus status = liftLunapark $ Status identity -setTimeouts ∷ ∀ r. LT.Timeouts → WithLunapark r Unit +setTimeouts ∷ ∀ r. LT.Timeouts → Run (LunaparkEffect r) Unit setTimeouts ts = liftLunapark $ SetTimeouts ts unit -getTimeouts ∷ ∀ r. WithLunapark r LT.Timeouts +getTimeouts ∷ ∀ r. Run (LunaparkEffect r) LT.Timeouts getTimeouts = liftLunapark $ GetTimeouts identity -go ∷ ∀ r. String → WithLunapark r Unit +go ∷ ∀ r. String → Run (LunaparkEffect r) Unit go uri = liftLunapark $ GoTo uri unit -getUrl ∷ ∀ r. WithLunapark r String +getUrl ∷ ∀ r. Run (LunaparkEffect r) String getUrl = liftLunapark $ GetUrl identity -forward ∷ ∀ r. WithLunapark r Unit +forward ∷ ∀ r. Run (LunaparkEffect r) Unit forward = liftLunapark $ Forward unit -back ∷ ∀ r. WithLunapark r Unit +back ∷ ∀ r. Run (LunaparkEffect r) Unit back = liftLunapark $ Back unit -refresh ∷ ∀ r. WithLunapark r Unit +refresh ∷ ∀ r. Run (LunaparkEffect r) Unit refresh = liftLunapark $ Refresh unit -getTitle ∷ ∀ r. WithLunapark r String +getTitle ∷ ∀ r. Run (LunaparkEffect r) String getTitle = liftLunapark $ GetTitle identity -getWindowHandle ∷ ∀ r. WithLunapark r LT.WindowHandle +getWindowHandle ∷ ∀ r. Run (LunaparkEffect r) LT.WindowHandle getWindowHandle = liftLunapark $ GetWindowHandle identity -getWindowHandles ∷ ∀ r. WithLunapark r (Array LT.WindowHandle) +getWindowHandles ∷ ∀ r. Run (LunaparkEffect r) (Array LT.WindowHandle) getWindowHandles = liftLunapark $ GetWindowHandles identity -closeWindow ∷ ∀ r. WithLunapark r Unit +closeWindow ∷ ∀ r. Run (LunaparkEffect r) Unit closeWindow = liftLunapark $ CloseWindow unit -switchToWindow ∷ ∀ r. LT.WindowHandle → WithLunapark r Unit +switchToWindow ∷ ∀ r. LT.WindowHandle → Run (LunaparkEffect r) Unit switchToWindow w = liftLunapark $ SwitchToWindow w unit -switchToFrame ∷ ∀ r. LT.FrameId → WithLunapark r Unit +switchToFrame ∷ ∀ r. LT.FrameId → Run (LunaparkEffect r) Unit switchToFrame f = liftLunapark $ SwitchToFrame f unit -switchToParentFrame ∷ ∀ r. WithLunapark r Unit +switchToParentFrame ∷ ∀ r. Run (LunaparkEffect r) Unit switchToParentFrame = liftLunapark $ SwitchToParentFrame unit -getWindowRectangle ∷ ∀ r. WithLunapark r LT.Rectangle +getWindowRectangle ∷ ∀ r. Run (LunaparkEffect r) LT.Rectangle getWindowRectangle = liftLunapark $ GetWindowRectangle identity -setWindowRectangle ∷ ∀ r. LT.Rectangle → WithLunapark r Unit +setWindowRectangle ∷ ∀ r. LT.Rectangle → Run (LunaparkEffect r) Unit setWindowRectangle r = liftLunapark $ SetWindowRectangle r unit -maximizeWindow ∷ ∀ r. WithLunapark r Unit +maximizeWindow ∷ ∀ r. Run (LunaparkEffect r) Unit maximizeWindow = liftLunapark $ MaximizeWindow unit -minimizeWindow ∷ ∀ r. WithLunapark r Unit +minimizeWindow ∷ ∀ r. Run (LunaparkEffect r) Unit minimizeWindow = liftLunapark $ MinimizeWindow unit -fullscreenWindow ∷ ∀ r. WithLunapark r Unit +fullscreenWindow ∷ ∀ r. Run (LunaparkEffect r) Unit fullscreenWindow = liftLunapark $ FullscreenWindow unit -executeScript ∷ ∀ r. LT.Script → WithLunapark r J.Json +executeScript ∷ ∀ r. LT.Script → Run (LunaparkEffect r) J.Json executeScript script = liftLunapark $ ExecuteScript script identity -executeScriptAsync ∷ ∀ r. LT.Script → WithLunapark r J.Json +executeScriptAsync ∷ ∀ r. LT.Script → Run (LunaparkEffect r) J.Json executeScriptAsync script = liftLunapark $ ExecuteScriptAsync script identity -getAllCookies ∷ ∀ r. WithLunapark r (Array LT.Cookie) +getAllCookies ∷ ∀ r. Run (LunaparkEffect r) (Array LT.Cookie) getAllCookies = liftLunapark $ GetAllCookies identity -getCookie ∷ ∀ r. String → WithLunapark r LT.Cookie +getCookie ∷ ∀ r. String → Run (LunaparkEffect r) LT.Cookie getCookie name = liftLunapark $ GetCookie name identity -addCookie ∷ ∀ r. LT.Cookie → WithLunapark r Unit +addCookie ∷ ∀ r. LT.Cookie → Run (LunaparkEffect r) Unit addCookie cookie = liftLunapark $ AddCookie cookie unit -deleteCookie ∷ ∀ r. String → WithLunapark r Unit +deleteCookie ∷ ∀ r. String → Run (LunaparkEffect r) Unit deleteCookie name = liftLunapark $ DeleteCookie name unit -deleteAllCookies ∷ ∀ r. WithLunapark r Unit +deleteAllCookies ∷ ∀ r. Run (LunaparkEffect r) Unit deleteAllCookies = liftLunapark $ DeleteAllCookies unit -dismissAlert ∷ ∀ r. WithLunapark r Unit +dismissAlert ∷ ∀ r. Run (LunaparkEffect r) Unit dismissAlert = liftLunapark $ DismissAlert unit -acceptAlert ∷ ∀ r. WithLunapark r Unit +acceptAlert ∷ ∀ r. Run (LunaparkEffect r) Unit acceptAlert = liftLunapark $ AcceptAlert unit -getAlertText ∷ ∀ r. WithLunapark r String +getAlertText ∷ ∀ r. Run (LunaparkEffect r) String getAlertText = liftLunapark $ GetAlertText identity -sendAlertText ∷ ∀ r. String → WithLunapark r Unit +sendAlertText ∷ ∀ r. String → Run (LunaparkEffect r) Unit sendAlertText txt = liftLunapark $ SendAlertText txt unit -screenshot ∷ ∀ r. String → WithLunapark r Unit +screenshot ∷ ∀ r. String → Run (LunaparkEffect r) Unit screenshot fp = liftLunapark $ Screenshot fp unit -elementScreenshot ∷ ∀ r. LT.Element → String → WithLunapark r Unit +elementScreenshot ∷ ∀ r. LT.Element → String → Run (LunaparkEffect r) Unit elementScreenshot el fp = liftLunapark $ OnElement el $ ScreenshotEl fp unit -findElement ∷ ∀ r. LT.Locator → WithLunapark r LT.Element +findElement ∷ ∀ r. LT.Locator → Run (LunaparkEffect r) LT.Element findElement l = liftLunapark $ FindElement l identity -findElements ∷ ∀ r. LT.Locator → WithLunapark r (Array LT.Element) +findElements ∷ ∀ r. LT.Locator → Run (LunaparkEffect r) (Array LT.Element) findElements l = liftLunapark $ FindElements l identity -childElement ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r LT.Element +childElement ∷ ∀ r. LT.Element → LT.Locator → Run (LunaparkEffect r) LT.Element childElement el l = liftLunapark $ OnElement el $ ChildElement l identity -childElements ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r (Array LT.Element) +childElements ∷ ∀ r. LT.Element → LT.Locator → Run (LunaparkEffect r) (Array LT.Element) childElements el l = liftLunapark $ OnElement el $ ChildElements l identity -isSelected ∷ ∀ r. LT.Element → WithLunapark r Boolean +isSelected ∷ ∀ r. LT.Element → Run (LunaparkEffect r) Boolean isSelected el = liftLunapark $ OnElement el $ IsSelected identity -getAttribute ∷ ∀ r. LT.Element → String → WithLunapark r String +getAttribute ∷ ∀ r. LT.Element → String → Run (LunaparkEffect r) String getAttribute el name = liftLunapark $ OnElement el $ GetAttribute name identity -getProperty ∷ ∀ r. LT.Element → String → WithLunapark r J.Json +getProperty ∷ ∀ r. LT.Element → String → Run (LunaparkEffect r) J.Json getProperty el name = liftLunapark $ OnElement el $ GetProperty name identity -getCss ∷ ∀ r. LT.Element → String → WithLunapark r String +getCss ∷ ∀ r. LT.Element → String → Run (LunaparkEffect r) String getCss el name = liftLunapark $ OnElement el $ GetCss name identity -getText ∷ ∀ r. LT.Element → WithLunapark r String +getText ∷ ∀ r. LT.Element → Run (LunaparkEffect r) String getText el = liftLunapark $ OnElement el $ GetText identity -getTagName ∷ ∀ r. LT.Element → WithLunapark r String +getTagName ∷ ∀ r. LT.Element → Run (LunaparkEffect r) String getTagName el = liftLunapark $ OnElement el $ GetTagName identity -getRectangle ∷ ∀ r. LT.Element → WithLunapark r LT.Rectangle +getRectangle ∷ ∀ r. LT.Element → Run (LunaparkEffect r) LT.Rectangle getRectangle el = liftLunapark $ OnElement el $ GetRectangle identity -isEnabled ∷ ∀ r. LT.Element → WithLunapark r Boolean +isEnabled ∷ ∀ r. LT.Element → Run (LunaparkEffect r) Boolean isEnabled el = liftLunapark $ OnElement el $ IsEnabled identity -clickElement ∷ ∀ r. LT.Element → WithLunapark r Unit +clickElement ∷ ∀ r. LT.Element → Run (LunaparkEffect r) Unit clickElement el = liftLunapark $ OnElement el $ ClickEl unit -clearElement ∷ ∀ r. LT.Element → WithLunapark r Unit +clearElement ∷ ∀ r. LT.Element → Run (LunaparkEffect r) Unit clearElement el = liftLunapark $ OnElement el $ ClearEl unit -sendKeysElement ∷ ∀ r. LT.Element → String → WithLunapark r Unit +sendKeysElement ∷ ∀ r. LT.Element → String → Run (LunaparkEffect r) Unit sendKeysElement el txt = liftLunapark $ OnElement el $ SendKeysEl txt unit -isDisplayed ∷ ∀ r. LT.Element → WithLunapark r Boolean +isDisplayed ∷ ∀ r. LT.Element → Run (LunaparkEffect r) Boolean isDisplayed el = liftLunapark $ OnElement el $ IsDisplayed identity -submitElement ∷ ∀ r. LT.Element → WithLunapark r Unit +submitElement ∷ ∀ r. LT.Element → Run (LunaparkEffect r) Unit submitElement el = liftLunapark $ OnElement el $ Submit unit -performActions ∷ ∀ r. LT.ActionRequest → WithLunapark r Unit +performActions ∷ ∀ r. LT.ActionRequest → Run (LunaparkEffect r) Unit performActions req = liftLunapark $ PerformActions req unit -releaseActions ∷ ∀ r. WithLunapark r Unit +releaseActions ∷ ∀ r. Run (LunaparkEffect r) Unit releaseActions = liftLunapark $ ReleaseActions unit diff --git a/src/Lunapark/Types.purs b/src/Lunapark/Types.purs index df62d9f..cbfc594 100644 --- a/src/Lunapark/Types.purs +++ b/src/Lunapark/Types.purs @@ -1,5 +1,5 @@ -- | This module contains types for requests and response. --- | Most of them are records with `α → Json` and `Json → Either String α` functions +-- | Most of them are records with `α → J.Json` and `J.Json → Either J.JsonDecodeError α` functions -- | not newtypes with `Encode|DecodeJson` instances. module Lunapark.Types where @@ -7,8 +7,8 @@ import Prelude import CSS as CSS import Control.Alt ((<|>)) -import Data.Argonaut.Core (Json) -import Data.Argonaut.Core (Json, jsonEmptyObject, jsonNull) as J +import Data.Argonaut.Core (Json, jsonEmptyObject, jsonNull, fromString) as J +import Data.Argonaut.Decode (JsonDecodeError(..)) as J import Data.Argonaut.Decode.Class (decodeJson) as J import Data.Argonaut.Decode.Combinators ((.:)) import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) as J @@ -54,17 +54,17 @@ derive instance newtypeElement ∷ Newtype Element _ derive newtype instance eqElement ∷ Eq Element derive newtype instance ordElement ∷ Ord Element -decodeElement ∷ Json → Either String Element +decodeElement ∷ J.Json → Either J.JsonDecodeError Element decodeElement = J.decodeJson >=> \obj → map Element $ obj .: "element-6066-11e4-a52e-4f735466cecf" <|> obj .: "ELEMENT" -encodeElement ∷ Element → Json +encodeElement ∷ Element → J.Json encodeElement (Element eid) = J.encodeJson $ FO.fromFoldable [ Tuple "element-6066-11e4-a52e-4f735466cecf" eid , Tuple "ELEMENT" eid ] -decodeSessionId ∷ Json → Either String SessionId +decodeSessionId ∷ J.Json → Either J.JsonDecodeError SessionId decodeSessionId = map SessionId <<< J.decodeJson type CreateSessionResponse = @@ -72,7 +72,7 @@ type CreateSessionResponse = , capabilities ∷ Array Capability } -decodeCreateSessionResponse ∷ Json → Either String CreateSessionResponse +decodeCreateSessionResponse ∷ J.Json → Either J.JsonDecodeError CreateSessionResponse decodeCreateSessionResponse = J.decodeJson >=> \obj → do session ← decodeSessionId =<< obj .: "sessionId" capabilities ← decodeCapabilities =<< obj .: "capabilities" @@ -83,7 +83,7 @@ type ServerStatus = , message ∷ String } -decodeServerStatus ∷ Json → Either String ServerStatus +decodeServerStatus ∷ J.Json → Either J.JsonDecodeError ServerStatus decodeServerStatus = J.decodeJson >=> \obj → { ready: _, message: _ } <$> obj .: "ready" <*> obj .: "message" type Timeouts = @@ -92,37 +92,37 @@ type Timeouts = , implicit ∷ Milliseconds } -decodeTimeouts ∷ Json → Either String Timeouts +decodeTimeouts ∷ J.Json → Either J.JsonDecodeError Timeouts decodeTimeouts = J.decodeJson >=> \obj → do script ← map Milliseconds $ obj .: "script" pageLoad ← map Milliseconds $ obj .: "pageLoad" implicit ← map Milliseconds $ obj .: "implicit" pure { script, pageLoad, implicit } -encodeTimeouts ∷ Timeouts → Json +encodeTimeouts ∷ Timeouts → J.Json encodeTimeouts r = J.encodeJson $ FO.fromFoldable [ Tuple "script" (un Milliseconds r.script) , Tuple "pageLoad" (un Milliseconds r.pageLoad) , Tuple "implicit" (un Milliseconds r.implicit) ] -encodeLegacyTimeouts ∷ Timeouts → Array Json +encodeLegacyTimeouts ∷ Timeouts → Array J.Json encodeLegacyTimeouts r = [ J.encodeJson $ FO.singleton "script" $ un Milliseconds r.script , J.encodeJson $ FO.singleton "implicit" $ un Milliseconds r.implicit , J.encodeJson $ FO.singleton "page load" $ un Milliseconds r.pageLoad ] -encodeGoRequest ∷ String → Json +encodeGoRequest ∷ String → J.Json encodeGoRequest url = J.encodeJson $ FO.fromFoldable [ Tuple "url" url ] -decodeWindowHandle ∷ Json → Either String WindowHandle +decodeWindowHandle ∷ J.Json → Either J.JsonDecodeError WindowHandle decodeWindowHandle = map WindowHandle <<< J.decodeJson -encodeSwitchToWindowRequest ∷ WindowHandle → Json +encodeSwitchToWindowRequest ∷ WindowHandle → J.Json encodeSwitchToWindowRequest w = J.encodeJson $ FO.fromFoldable [ Tuple "handle" $ un WindowHandle w ] -encodeFrameId ∷ FrameId → Json +encodeFrameId ∷ FrameId → J.Json encodeFrameId fid = J.encodeJson $ FO.fromFoldable [ Tuple "id" encoded ] where encoded = case fid of @@ -137,7 +137,7 @@ type Rectangle = , y ∷ Int } -decodeRectangle ∷ Json → Either String Rectangle +decodeRectangle ∷ J.Json → Either J.JsonDecodeError Rectangle decodeRectangle = J.decodeJson >=> \obj → do width ← obj .: "width" height ← obj .: "height" @@ -145,7 +145,7 @@ decodeRectangle = J.decodeJson >=> \obj → do y ← obj .: "y" pure { width, height, x, y } -decodeRectangleLegacy ∷ { size ∷ Json, position ∷ Json } → Either String Rectangle +decodeRectangleLegacy ∷ { size ∷ J.Json, position ∷ J.Json } → Either J.JsonDecodeError Rectangle decodeRectangleLegacy { size, position } = do sobj ← J.decodeJson size pobj ← J.decodeJson position @@ -155,13 +155,13 @@ decodeRectangleLegacy { size, position } = do height ← sobj .: "height" pure { width, height, x, y } -encodeRectangleLegacy ∷ Rectangle → { size ∷ Json, position ∷ Json } +encodeRectangleLegacy ∷ Rectangle → { size ∷ J.Json, position ∷ J.Json } encodeRectangleLegacy r = { size: J.encodeJson $ FO.fromFoldable [ Tuple "width" r.width, Tuple "height" r.height ] , position: J.encodeJson $ FO.fromFoldable [ Tuple "x" r.x, Tuple "y" r.y ] } -encodeRectangle ∷ Rectangle → Json +encodeRectangle ∷ Rectangle → J.Json encodeRectangle r = J.encodeJson $ FO.fromFoldable [ Tuple "width" r.width , Tuple "height" r.height @@ -182,7 +182,7 @@ type RawLocator = , value ∷ String } -encodeLocator ∷ Locator → Json +encodeLocator ∷ Locator → J.Json encodeLocator l = J.encodeJson $ FO.fromFoldable case l of ByCss sel → [ Tuple "using" "css selector" @@ -209,15 +209,15 @@ encodeLocator l = J.encodeJson $ FO.fromFoldable case l of , Tuple "value" r.value ] -encodeSendKeysRequest ∷ String → Json +encodeSendKeysRequest ∷ String → J.Json encodeSendKeysRequest txt = J.encodeJson $ FO.fromFoldable [ Tuple "text" txt ] type Script = { script ∷ String - , args ∷ Array Json + , args ∷ Array J.Json } -encodeScript ∷ Script → Json +encodeScript ∷ Script → J.Json encodeScript r = J.encodeJson $ FO.fromFoldable [ Tuple "script" $ J.encodeJson r.script , Tuple "args" $ J.encodeJson r.args @@ -233,7 +233,7 @@ type Cookie = , expiry ∷ Maybe Int } -encodeCookie ∷ Cookie → Json +encodeCookie ∷ Cookie → J.Json encodeCookie r = J.encodeJson $ FO.fromFoldable [ Tuple "cookie" $ FO.fromFoldable $ [ Tuple "name" $ J.encodeJson r.name @@ -249,7 +249,7 @@ encodeCookie r = J.encodeJson $ FO.fromFoldable maybeToAOfPair ∷ ∀ a. J.EncodeJson a ⇒ String → Maybe a → Array (Tuple String J.Json) maybeToAOfPair key mb = F.foldMap (A.singleton <<< Tuple key <<< J.encodeJson) mb -decodeCookie ∷ Json → Either String Cookie +decodeCookie ∷ J.Json → Either J.JsonDecodeError Cookie decodeCookie = J.decodeJson >=> \obj → do name ← obj .: "name" value ← obj .: "value" @@ -277,13 +277,13 @@ type Screenshot = , encoding ∷ NE.Encoding } -decodeScreenshot ∷ Json → Either String Screenshot +decodeScreenshot ∷ J.Json → Either J.JsonDecodeError Screenshot decodeScreenshot j = { content: _, encoding: NE.Base64 } <$> J.decodeJson j data Button = LeftBtn | MiddleBtn | RightBtn -encodeButton ∷ Button → Json +encodeButton ∷ Button → J.Json encodeButton = J.encodeJson <<< case _ of LeftBtn → 0 MiddleBtn → 1 @@ -294,7 +294,7 @@ data PointerMoveOrigin | FromPointer | FromElement Element -encodeOrigin ∷ PointerMoveOrigin → Json +encodeOrigin ∷ PointerMoveOrigin → J.Json encodeOrigin = case _ of FromViewport → J.encodeJson "viewport" FromPointer → J.encodeJson "pointer" @@ -307,7 +307,7 @@ type PointerMove = , y ∷ Int } -encodePointerMove ∷ PointerMove → FO.Object Json +encodePointerMove ∷ PointerMove → FO.Object J.Json encodePointerMove r = FO.fromFoldable [ Tuple "x" $ J.encodeJson r.x , Tuple "y" $ J.encodeJson r.y @@ -343,7 +343,7 @@ pointerDown = V.inj (SProxy ∷ SProxy "pointerDown") pointerMove ∷ ∀ r a. a → V.Variant (pointerMove ∷ a|r) pointerMove = V.inj (SProxy ∷ SProxy "pointerMove") -encodeAction ∷ Action → Json +encodeAction ∷ Action → J.Json encodeAction = V.match { pause: \ms → J.encodeJson $ FO.fromFoldable @@ -394,17 +394,17 @@ data ActionSequence -- Right, this is not an `Array` but `StrMap` because all `ActionSequence`s are tagged with unique id's type ActionRequest = FO.Object ActionSequence -encodeActionRequest ∷ ActionRequest → Json +encodeActionRequest ∷ ActionRequest → J.Json encodeActionRequest sm = J.encodeJson $ FO.singleton "actions" $ map encodePair arrayOfPairs where arrayOfPairs ∷ Array (Tuple String ActionSequence) arrayOfPairs = FO.toUnfoldable sm - encodePair ∷ Tuple String ActionSequence → Json + encodePair ∷ Tuple String ActionSequence → J.Json encodePair (Tuple identifier sequence) = J.encodeJson $ FO.insert "id" (J.encodeJson identifier) $ encodeSequence sequence - encodeSequence ∷ ActionSequence → FO.Object Json + encodeSequence ∷ ActionSequence → FO.Object J.Json encodeSequence = case _ of NoSource as → FO.fromFoldable [ Tuple "type" $ J.encodeJson "none" @@ -462,10 +462,10 @@ data Capability | PageLoadStrategy PageLoad | DesiredTimeouts Timeouts | UnhandledPromptBehavior UnhandledPrompt - | CustomCapability String Json + | CustomCapability String J.Json -encodeCapability ∷ Capability → Tuple String Json +encodeCapability ∷ Capability → Tuple String J.Json encodeCapability = case _ of BrowserName bn → Tuple "browserName" $ J.encodeJson case bn of MSEdge → "MicrosoftEdge" @@ -488,50 +488,50 @@ encodeCapability = case _ of Dismiss → "dismiss" CustomCapability k v → Tuple k v -encodeCapabilities ∷ ∀ f. F.Foldable f ⇒ f Capability → Json +encodeCapabilities ∷ ∀ f. F.Foldable f ⇒ f Capability → J.Json encodeCapabilities = F.foldl (\b a → J.extend (encodeCapability a) b) J.jsonEmptyObject -decodeCapabilities ∷ Json → Either String (Array Capability) +decodeCapabilities ∷ J.Json → Either J.JsonDecodeError (Array Capability) decodeCapabilities = J.decodeJson >=> \obj → F.for (FO.toUnfoldable obj) \l@(Tuple key val) → decodeCapability l <|> Right (CustomCapability key val) where - decodeCapability ∷ Tuple String Json → Either String Capability + decodeCapability ∷ Tuple String J.Json → Either J.JsonDecodeError Capability decodeCapability (Tuple key val) = case key of - "browserName" → BrowserName <$> decodeBrowserName val + "browserName" → BrowserName <$> decodeBrowserType val "browserVersion" → BrowserVersion <$> J.decodeJson val "acceptInsecureCerts" → AcceptInsecureCerts <$> J.decodeJson val - "pageLoadStrategy" → PageLoadStrategy <$> decodePageLoadStrategy val + "pageLoadStrategy" → PageLoadStrategy <$> decodePageLoad val "timeouts" → DesiredTimeouts <$> decodeTimeouts val - "unhandledPromptBehaviour" → UnhandledPromptBehavior <$> decodePrompt val - _ → Left "unhandled" + "unhandledPromptBehaviour" → UnhandledPromptBehavior <$> decodeUnhandledPrompt val + other → Left $ J.Named "Capability" $ J.UnexpectedValue (J.fromString other) - decodeBrowserName ∷ Json → Either String BrowserType - decodeBrowserName = J.decodeJson >=> \str → case Str.toLower str of + decodeBrowserType ∷ J.Json → Either J.JsonDecodeError BrowserType + decodeBrowserType = J.decodeJson >=> \str → case Str.toLower str of "microsoftedge" → Right MSEdge "chrome" → Right Chrome "firefox" → Right Firefox - _ → Left "unhandled" + other → Left $ J.Named "BrowserType" $ J.UnexpectedValue (J.fromString other) - decodePageLoadStrategy ∷ Json → Either String PageLoad - decodePageLoadStrategy = J.decodeJson >=> \str → case Str.toLower str of + decodePageLoad ∷ J.Json → Either J.JsonDecodeError PageLoad + decodePageLoad = J.decodeJson >=> \str → case Str.toLower str of "none" → Right Immediate "normal" → Right Normal "eager" → Right Eager - _ → Left "unhandled" + other → Left $ J.Named "PageLoad" $ J.UnexpectedValue (J.fromString other) - decodePrompt ∷ Json → Either String UnhandledPrompt - decodePrompt = J.decodeJson >=> \str → case Str.toLower str of + decodeUnhandledPrompt ∷ J.Json → Either J.JsonDecodeError UnhandledPrompt + decodeUnhandledPrompt = J.decodeJson >=> \str → case Str.toLower str of "accept" → Right Accept "dismiss" → Right Dismiss - _ → Left "unhandled" + other → Left $ J.Named "UnhandledPrompt" $ J.UnexpectedValue (J.fromString other) type CapabilitiesRequest = { alwaysMatch ∷ Array Capability , firstMatch ∷ Array (Array Capability) } -encodeCapabilitiesRequest ∷ CapabilitiesRequest → Json +encodeCapabilitiesRequest ∷ CapabilitiesRequest → J.Json encodeCapabilitiesRequest r = J.encodeJson $ FO.singleton "capabilities" $ FO.fromFoldable [ Tuple "alwaysMatch" $ encodeCapabilities r.alwaysMatch , Tuple "firstMatch" $ J.encodeJson $ map encodeCapabilities r.firstMatch @@ -543,7 +543,7 @@ type MoveToRequest = , yoffset ∷ Int } -encodeMoveToRequest ∷ MoveToRequest → Json +encodeMoveToRequest ∷ MoveToRequest → J.Json encodeMoveToRequest r = J.encodeJson $ FO.fromFoldable [ Tuple "element" $ case r.element of Nothing → J.jsonNull diff --git a/src/Lunapark/Utils.purs b/src/Lunapark/Utils.purs index da5182e..0561a9d 100644 --- a/src/Lunapark/Utils.purs +++ b/src/Lunapark/Utils.purs @@ -2,9 +2,10 @@ module Lunapark.Utils where import Prelude -import Effect.Aff (Aff) +import Data.Argonaut.Decode (JsonDecodeError) as J import Data.Bifunctor (lmap) import Data.Either (Either) +import Effect.Aff (Aff) import Lunapark.Error as LE import Run as R import Run.Except as RE @@ -18,12 +19,12 @@ liftAndRethrow a = do res ← R.liftAff a RE.rethrow res -throwLeft +rethrowAsJsonDecodeError ∷ ∀ r - . Either String + . Either J.JsonDecodeError ~> R.Run (except ∷ RE.EXCEPT LE.Error|r) -throwLeft = - RE.rethrow <<< lmap LE.unknownError +rethrowAsJsonDecodeError = + RE.rethrow <<< lmap LE.JsonDecodeError -- Safe, since we actually want handler and result have same rows not, remove except catch diff --git a/src/Lunapark/WebDriverError.purs b/src/Lunapark/WebDriverError.purs new file mode 100644 index 0000000..4af1065 --- /dev/null +++ b/src/Lunapark/WebDriverError.purs @@ -0,0 +1,117 @@ +module Lunapark.WebDriverError where + +import Prelude + +import Data.Argonaut.Core (Json, fromString) as J +import Data.Argonaut.Decode (JsonDecodeError(..)) as J +import Data.Argonaut.Decode.Combinators ((.:)) as J +import Data.Argonaut.Decode.Class (decodeJson) as J +import Data.Either (Either(..)) + +data WebDriverErrorType + = ElementClickIntercepted + | ElementNotSelectable + | ElementNotInteractable + | InsecureCertificate + | InvalidArgument + | InvalidCookieDomain + | InvalidCoordinates + | InvalidElementState + | InvalidSelector + | InvalidSessionId + | JavaScriptError + | MoveTargetOutOfBounds + | NoSuchAlert + | NoSuchCookie + | NoSuchElement + | NoSuchFrame + | NoSuchWindow + | ScriptTimeout + | SessionNotCreated + | StaleElementReference + | Timeout + | UnableToSetCookie + | UnableToCaptureScreen + | UnexpectedAlertOpen + | UnknownCommand + | UnknownError + | UnknownMethod + | UnsupportedOperation + +fromStringCode ∷ String → Either J.JsonDecodeError WebDriverErrorType +fromStringCode = case _ of + "element click intercepted" → Right ElementClickIntercepted + "element not selectable" → Right ElementNotSelectable + "element not interactable" → Right ElementNotInteractable + "insecure certificate" → Right InsecureCertificate + "invalid argument" → Right InvalidArgument + "invalid cookie domain" → Right InvalidCookieDomain + "invalid coordinates" → Right InvalidCoordinates + "invalid element state" → Right InvalidElementState + "invalid selector" → Right InvalidSelector + "invalid session id" → Right InvalidSessionId + "javascript error" → Right JavaScriptError + "move target out of bounds" → Right MoveTargetOutOfBounds + "no such alert" → Right NoSuchAlert + "no such cookie" → Right NoSuchCookie + "no such element" → Right NoSuchElement + "no such frame" → Right NoSuchFrame + "no such window" → Right NoSuchWindow + "script timeout" → Right ScriptTimeout + "session not created" → Right SessionNotCreated + "stale element reference" → Right StaleElementReference + "timeout" → Right Timeout + "unable to set cookie" → Right UnableToSetCookie + "unable to capture screen" → Right UnableToCaptureScreen + "unexpected alert open" → Right UnexpectedAlertOpen + "unknown command" → Right UnknownCommand + "unknown error" → Right UnknownError + "unknown method" → Right UnknownMethod + "unsupported operation" → Right UnsupportedOperation + s → Left $ J.Named "WebDriverErrorType" $ J.UnexpectedValue $ J.fromString s + +toStringCode ∷ WebDriverErrorType → String +toStringCode = case _ of + ElementClickIntercepted → "element click intercepted" + ElementNotSelectable → "element not selectable" + ElementNotInteractable → "element not interactable" + InsecureCertificate → "insecure certificate" + InvalidArgument → "invalid argument" + InvalidCookieDomain → "invalid cookie domain" + InvalidCoordinates → "invalid coordinates" + InvalidElementState → "invalid element state" + InvalidSelector → "invalid selector" + InvalidSessionId → "invalid session id" + JavaScriptError → "javascript error" + MoveTargetOutOfBounds → "move target out of bounds" + NoSuchAlert → "no such alert" + NoSuchCookie → "no such cookie" + NoSuchElement → "no such element" + NoSuchFrame → "no such frame" + NoSuchWindow → "no such window" + ScriptTimeout → "script timeout" + SessionNotCreated → "session not created" + StaleElementReference → "stale element reference" + Timeout → "timeout" + UnableToSetCookie → "unable to set cookie" + UnableToCaptureScreen → "unable to capture screen" + UnexpectedAlertOpen → "unexpected alert open" + UnknownCommand → "unknown command" + UnknownError → "unknown error" + UnknownMethod → "unknown method" + UnsupportedOperation → "unsupported operation" + +type WebDriverError = + { error ∷ WebDriverErrorType + , message ∷ String + , stacktrace ∷ String + } + +fromJson ∷ J.Json → Either J.JsonDecodeError WebDriverError +fromJson js = do + obj ← J.decodeJson js + value ← obj J..: "value" + error ← fromStringCode =<< value J..: "error" + message ← value J..: "message" + stacktrace ← value J..: "stacktrace" + pure { error, message, stacktrace }