@@ -3,19 +3,24 @@ module Lunapark.API where
33import Prelude
44
55import Control.Monad.Aff (Aff)
6+import Control.Monad.Aff as Aff
67import Control.Monad.Aff.Class (class MonadAff, liftAff)
78import Control.Monad.Eff.Ref as Ref
9+import Control.Monad.Eff.Class (liftEff)
810import Control.Monad.Error.Class (class MonadThrow)
911import Control.Monad.Rec.Class (class MonadRec)
1012import Data.Argonaut as J
1113import Data.Bifunctor (lmap)
12−import Data.Either (Either)
14+import Data.Either (Either(..), isRight)
1315import Data.List (List(..), (:))
1416import Data.Map as Map
1517import Data.Maybe (Maybe(..))
1618import Data.Symbol (SProxy(..))
19+import Data.StrMap as SM
20+import Data.Variant as V
1721import Data.Time.Duration (Milliseconds(..))
1822import Data.Traversable as T
23+import Data.Tuple (Tuple(..))
1924import Lunapark.Endpoint as LP
2025import Lunapark.Error as LE
2126import Lunapark.Types as LT
@@ -27,7 +32,7 @@ import Run.Except (EXCEPT)
2732import Run.Except as RE
2833import Unsafe.Coerce (unsafeCoerce)
2934
30−import Debug.Trace as DT
35+--import Debug.Trace as DT
3136
3237type LunaparkEffects e =
3338 ( ajax ∷ AJAX
@@ -51,22 +56,53 @@ init
5156 ⇒ MonadThrow LE.Error m
5257 ⇒ String
5358 → LT.CapabilitiesRequest
54− → m (Either LE.Error (Lunapark e r a → BaseRun r e a))
59+ → m (Either LE.Error (Lunapark e r a → BaseRun e r a))
5560init uri caps = do
56− res ← liftAff $ LP.post uri (LP.Session : Nil) $ LT.encodeCapabilitiesRequest caps
57− pure do
58− sessObj ← res
59− sessionResponse ← lmap LE.unknownError $ LT.decodeCreateSessionResponse sessObj
60− pure $ interpret uri sessionResponse
61+ res ←
62+ liftAff
63+ $ LP.post uri (LP.Session : Nil)
64+ $ LT.encodeCapabilitiesRequest caps
65+
66+ let
67+ sessionResponse = do
68+ sessObj ← res
69+ lmap LE.unknownError $ LT.decodeCreateSessionResponse sessObj
70+
71+ T.for sessionResponse \{ session, capabilities } → do
72+ timeoutsRef ←
73+ liftEff $ Ref.newRef
74+ { implicit: Milliseconds 0.0
75+ , pageLoad: Milliseconds 300000.0
76+ , script: Milliseconds 30000.0
77+ }
78+
79+ requestMapRef ← liftEff $ Ref.newRef Map.empty
80+
81+ actionsEnabled ←
82+ map isRight
83+ $ liftAff
84+ $ LP.post uri (LP.InSession session : LP.Actions : Nil)
85+ $ LT.encodeActionRequest $ SM.fromFoldable
86+ [ Tuple "id" $ LT.NoSource [ V.inj (SProxy ∷ SProxy "pause") $ Milliseconds 0.0 ] ]
87+
88+ let
89+ input =
90+ { timeoutsRef
91+ , requestMapRef
92+ , uri
93+ , session
94+ , capabilities
95+ , actionsEnabled
96+ }
97+
98+ pure $ interpret input
6199
62100interpret
63101 ∷ ∀ e r
64− . String
65− → LT.CreateSessionResponse
102+ . HandleLunaparkInput
66103 → Lunapark e r
67− ~> BaseRun r e
68−interpret uri {session, capabilities} =
69− runLunapark uri session capabilities
104+ ~> BaseRun e r
105+interpret input = runLunapark input <<< runLunaparkActions input
70106
71107data LunaparkF a
72108 = Quit a
@@ -106,6 +142,8 @@ data LunaparkF a
106142 | FindElement LT.Locator (LT.Element → a)
107143 | FindElements LT.Locator (Array LT.Element → a)
108144 | OnElement LT.Element (ElementF a)
145+ | PerformActions LT.ActionRequest a
146+ | ReleaseActions a
109147
110148data ElementF a
111149 = ChildElement LT.Locator (LT.Element → a)
@@ -120,198 +158,263 @@ data ElementF a
120158 | IsEnabled (Boolean → a)
121159 | ClickEl a
122160 | ClearEl a
123− | SendKeys String a
161+ | SendKeysEl String a
124162 | ScreenshotEl String a
125163 | IsDisplayed (Boolean → a)
126164 | Submit a
127165
166+data ActionF a
167+ = Click LT.Button a
168+ | ButtonDown LT.Button a
169+ | ButtonUp LT.Button a
170+ | DoubleClick a
171+ | SendKeys String a
172+ | MoveTo LT.PointerMove a
173+ | Touch (TouchF a)
174+ | Pause Milliseconds a
175+
176+data TouchF a
177+ = Tap a
178+ | TouchDown a
179+ | TouchUp a
180+ | LongClick a
181+ | Flick a
182+ | Scroll a
183+ | DoubleTap a
184+
128185derive instance functorLunaparkF ∷ Functor LunaparkF
129−derive instance elementF ∷ Functor ElementF
186+derive instance functorElementF ∷ Functor ElementF
187+derive instance functorActionF ∷ Functor ActionF
188+derive instance functorTouchF ∷ Functor TouchF
130189
131−type BaseRun r e = R.Run
190+type BaseRun e r = R.Run
132191 ( except ∷ EXCEPT LE.Error
133192 , aff ∷ R.AFF (LunaparkEffects e)
134193 , eff ∷ R.EFF (LunaparkEffects e)
135194 | r)
136195
137−type Lunapark e r = BaseRun (lunapark ∷ LUNAPARK|r) e
196+type Lunapark e r = BaseRun e (lunapark ∷ LUNAPARK, lunaparkActions ∷ LUNAPARK_ACTIONS|r)
138197
139198_lunapark = SProxy ∷ SProxy "lunapark"
199+_lunaparkActions = SProxy ∷ SProxy "lunaparkActions"
140200type LUNAPARK = R.FProxy LunaparkF
201+type LUNAPARK_ACTIONS = R.FProxy ActionF
202+type WithLunapark r a = R.Run (lunapark ∷ LUNAPARK|r) a
141203
142−liftLunapark ∷ ∀ a r e. LunaparkF a → Lunapark e r a
204+liftLunapark ∷ ∀ a r. LunaparkF a → WithLunapark r a
143205liftLunapark = R.lift _lunapark
144206
145−quit ∷ ∀ e r. Lunapark e r Unit
207+quit ∷ ∀ r. WithLunapark r Unit
146208quit = liftLunapark $ Quit unit
147209
148−status ∷ ∀ e r. Lunapark e r LT.ServerStatus
210+status ∷ ∀ r. WithLunapark r LT.ServerStatus
149211status = liftLunapark $ Status id
150212
151−setTimeouts ∷ ∀ e r. LT.Timeouts → Lunapark e r Unit
213+setTimeouts ∷ ∀ r. LT.Timeouts → WithLunapark r Unit
152214setTimeouts ts = liftLunapark $ SetTimeouts ts unit
153215
154−getTimeouts ∷ ∀ e r. Lunapark e r LT.Timeouts
216+getTimeouts ∷ ∀ r. WithLunapark r LT.Timeouts
155217getTimeouts = liftLunapark $ GetTimeouts id
156218
157−go ∷ ∀ e r. String → Lunapark e r Unit
219+go ∷ ∀ r. String → WithLunapark r Unit
158220go uri = liftLunapark $ GoTo uri unit
159221
160−getUrl ∷ ∀ e r. Lunapark e r String
222+getUrl ∷ ∀ r. WithLunapark r String
161223getUrl = liftLunapark $ GetUrl id
162224
163−forward ∷ ∀ e r. Lunapark e r Unit
225+forward ∷ ∀ r. WithLunapark r Unit
164226forward = liftLunapark $ Forward unit
165227
166−back ∷ ∀ e r. Lunapark e r Unit
228+back ∷ ∀ r. WithLunapark r Unit
167229back = liftLunapark $ Back unit
168230
169−refresh ∷ ∀ e r. Lunapark e r Unit
231+refresh ∷ ∀ r. WithLunapark r Unit
170232refresh = liftLunapark $ Refresh unit
171233
172−getTitle ∷ ∀ e r. Lunapark e r String
234+getTitle ∷ ∀ r. WithLunapark r String
173235getTitle = liftLunapark $ GetTitle id
174236
175−getWindowHandle ∷ ∀ e r. Lunapark e r LT.WindowHandle
237+getWindowHandle ∷ ∀ r. WithLunapark r LT.WindowHandle
176238getWindowHandle = liftLunapark $ GetWindowHandle id
177239
178−getWindowHandles ∷ ∀ e r. Lunapark e r (Array LT.WindowHandle)
240+getWindowHandles ∷ ∀ r. WithLunapark r (Array LT.WindowHandle)
179241getWindowHandles = liftLunapark $ GetWindowHandles id
180242
181−closeWindow ∷ ∀ e r. Lunapark e r Unit
243+closeWindow ∷ ∀ r. WithLunapark r Unit
182244closeWindow = liftLunapark $ CloseWindow unit
183245
184−switchToWindow ∷ ∀ e r. LT.WindowHandle → Lunapark e r Unit
246+switchToWindow ∷ ∀ r. LT.WindowHandle → WithLunapark r Unit
185247switchToWindow w = liftLunapark $ SwitchToWindow w unit
186248
187−switchToFrame ∷ ∀ e r. LT.FrameId → Lunapark e r Unit
249+switchToFrame ∷ ∀ r. LT.FrameId → WithLunapark r Unit
188250switchToFrame f = liftLunapark $ SwitchToFrame f unit
189251
190−switchToParentFrame ∷ ∀ e r. Lunapark e r Unit
252+switchToParentFrame ∷ ∀ r. WithLunapark r Unit
191253switchToParentFrame = liftLunapark $ SwitchToParentFrame unit
192254
193−getWindowRectangle ∷ ∀ e r. Lunapark e r LT.Rectangle
255+getWindowRectangle ∷ ∀ r. WithLunapark r LT.Rectangle
194256getWindowRectangle = liftLunapark $ GetWindowRectangle id
195257
196−setWindowRectangle ∷ ∀ e r. LT.Rectangle → Lunapark e r Unit
258+setWindowRectangle ∷ ∀ r. LT.Rectangle → WithLunapark r Unit
197259setWindowRectangle r = liftLunapark $ SetWindowRectangle r unit
198260
199−maximizeWindow ∷ ∀ e r. Lunapark e r Unit
261+maximizeWindow ∷ ∀ r. WithLunapark r Unit
200262maximizeWindow = liftLunapark $ MaximizeWindow unit
201263
202−minimizeWindow ∷ ∀ e r. Lunapark e r Unit
264+minimizeWindow ∷ ∀ r. WithLunapark r Unit
203265minimizeWindow = liftLunapark $ MinimizeWindow unit
204266
205−fullscreenWindow ∷ ∀ e r. Lunapark e r Unit
267+fullscreenWindow ∷ ∀ r. WithLunapark r Unit
206268fullscreenWindow = liftLunapark $ FullscreenWindow unit
207269
208−executeScript ∷ ∀ e r. LT.Script → Lunapark e r J.Json
270+executeScript ∷ ∀ r. LT.Script → WithLunapark r J.Json
209271executeScript script = liftLunapark $ ExecuteScript script id
210272
211−executeScriptAsync ∷ ∀ e r. LT.Script → Lunapark e r J.Json
273+executeScriptAsync ∷ ∀ r. LT.Script → WithLunapark r J.Json
212274executeScriptAsync script = liftLunapark $ ExecuteScriptAsync script id
213275
214−getAllCookies ∷ ∀ e r. Lunapark e r (Array LT.Cookie)
276+getAllCookies ∷ ∀ r. WithLunapark r (Array LT.Cookie)
215277getAllCookies = liftLunapark $ GetAllCookies id
216278
217−getCookie ∷ ∀ e r. String → Lunapark e r LT.Cookie
279+getCookie ∷ ∀ r. String → WithLunapark r LT.Cookie
218280getCookie name = liftLunapark $ GetCookie name id
219281
220−addCookie ∷ ∀ e r. LT.Cookie → Lunapark e r Unit
282+addCookie ∷ ∀ r. LT.Cookie → WithLunapark r Unit
221283addCookie cookie = liftLunapark $ AddCookie cookie unit
222284
223−deleteCookie ∷ ∀ e r. String → Lunapark e r Unit
285+deleteCookie ∷ ∀ r. String → WithLunapark r Unit
224286deleteCookie name = liftLunapark $ DeleteCookie name unit
225287
226−deleteAllCookies ∷ ∀ e r. Lunapark e r Unit
288+deleteAllCookies ∷ ∀ r. WithLunapark r Unit
227289deleteAllCookies = liftLunapark $ DeleteAllCookies unit
228290
229−dismissAlert ∷ ∀ e r. Lunapark e r Unit
291+dismissAlert ∷ ∀ r. WithLunapark r Unit
230292dismissAlert = liftLunapark $ DismissAlert unit
231293
232−acceptAlert ∷ ∀ e r. Lunapark e r Unit
294+acceptAlert ∷ ∀ r. WithLunapark r Unit
233295acceptAlert = liftLunapark $ AcceptAlert unit
234296
235−getAlertText ∷ ∀ e r. Lunapark e r String
297+getAlertText ∷ ∀ r. WithLunapark r String
236298getAlertText = liftLunapark $ GetAlertText id
237299
238−sendAlertText ∷ ∀ e r. String → Lunapark e r Unit
300+sendAlertText ∷ ∀ r. String → WithLunapark r Unit
239301sendAlertText txt = liftLunapark $ SendAlertText txt unit
240302
241−screenshot ∷ ∀ e r. String → Lunapark e r Unit
303+screenshot ∷ ∀ r. String → WithLunapark r Unit
242304screenshot fp = liftLunapark $ Screenshot fp unit
243305
244−elementScreenshot ∷ ∀ e r. LT.Element → String → Lunapark e r Unit
306+elementScreenshot ∷ ∀ r. LT.Element → String → WithLunapark r Unit
245307elementScreenshot el fp = liftLunapark $ OnElement el $ ScreenshotEl fp unit
246308
247−findElement ∷ ∀ e r. LT.Locator → Lunapark e r LT.Element
309+findElement ∷ ∀ r. LT.Locator → WithLunapark r LT.Element
248310findElement l = liftLunapark $ FindElement l id
249311
250−findElements ∷ ∀ e r. LT.Locator → Lunapark e r (Array LT.Element)
312+findElements ∷ ∀ r. LT.Locator → WithLunapark r (Array LT.Element)
251313findElements l = liftLunapark $ FindElements l id
252314
253−childElement ∷ ∀ e r. LT.Element → LT.Locator → Lunapark e r LT.Element
315+childElement ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r LT.Element
254316childElement el l = liftLunapark $ OnElement el $ ChildElement l id
255317
256−childElements ∷ ∀ e r. LT.Element → LT.Locator → Lunapark e r (Array LT.Element)
318+childElements ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r (Array LT.Element)
257319childElements el l = liftLunapark $ OnElement el $ ChildElements l id
258320
259−isSelected ∷ ∀ e r. LT.Element → Lunapark e r Boolean
321+isSelected ∷ ∀ r. LT.Element → WithLunapark r Boolean
260322isSelected el = liftLunapark $ OnElement el $ IsSelected id
261323
262−getAttribute ∷ ∀ e r. LT.Element → String → Lunapark e r String
324+getAttribute ∷ ∀ r. LT.Element → String → WithLunapark r String
263325getAttribute el name = liftLunapark $ OnElement el $ GetAttribute name id
264326
265−getProperty ∷ ∀ e r. LT.Element → String → Lunapark e r J.Json
327+getProperty ∷ ∀ r. LT.Element → String → WithLunapark r J.Json
266328getProperty el name = liftLunapark $ OnElement el $ GetProperty name id
267329
268−getCss ∷ ∀ e r. LT.Element → String → Lunapark e r String
330+getCss ∷ ∀ r. LT.Element → String → WithLunapark r String
269331getCss el name = liftLunapark $ OnElement el $ GetCss name id
270332
271−getText ∷ ∀ e r. LT.Element → Lunapark e r String
333+getText ∷ ∀ r. LT.Element → WithLunapark r String
272334getText el = liftLunapark $ OnElement el $ GetText id
273335
274−getTagName ∷ ∀ e r. LT.Element → Lunapark e r String
336+getTagName ∷ ∀ r. LT.Element → WithLunapark r String
275337getTagName el = liftLunapark $ OnElement el $ GetTagName id
276338
277−getRectangle ∷ ∀ e r. LT.Element → Lunapark e r LT.Rectangle
339+getRectangle ∷ ∀ r. LT.Element → WithLunapark r LT.Rectangle
278340getRectangle el = liftLunapark $ OnElement el $ GetRectangle id
279341
280−isEnabled ∷ ∀ e r. LT.Element → Lunapark e r Boolean
342+isEnabled ∷ ∀ r. LT.Element → WithLunapark r Boolean
281343isEnabled el = liftLunapark $ OnElement el $ IsEnabled id
282344
283−clickElement ∷ ∀ e r. LT.Element → Lunapark e r Unit
345+clickElement ∷ ∀ r. LT.Element → WithLunapark r Unit
284346clickElement el = liftLunapark $ OnElement el $ ClickEl unit
285347
286−clearElement ∷ ∀ e r. LT.Element → Lunapark e r Unit
348+clearElement ∷ ∀ r. LT.Element → WithLunapark r Unit
287349clearElement el = liftLunapark $ OnElement el $ ClearEl unit
288350
289−sendKeysElement ∷ ∀ e r. LT.Element → String → Lunapark e r Unit
290−sendKeysElement el txt = liftLunapark $ OnElement el $ SendKeys txt unit
351+sendKeysElement ∷ ∀ r. LT.Element → String → WithLunapark r Unit
352+sendKeysElement el txt = liftLunapark $ OnElement el $ SendKeysEl txt unit
291353
292−isDisplayed ∷ ∀ e r. LT.Element → Lunapark e r Boolean
354+isDisplayed ∷ ∀ r. LT.Element → WithLunapark r Boolean
293355isDisplayed el = liftLunapark $ OnElement el $ IsDisplayed id
294356
295−submitElement ∷ ∀ e r. LT.Element → Lunapark e r Unit
357+submitElement ∷ ∀ r. LT.Element → WithLunapark r Unit
296358submitElement el = liftLunapark $ OnElement el $ Submit unit
297359
298−runLunapark ∷ ∀ e r. String → LT.SessionId → Array LT.Capability → Lunapark e r ~> BaseRun r e
299−runLunapark uri session capabilities a = do
300− timeoutsRef ←
301− R.liftEff $ Ref.newRef
302− { implicit: Milliseconds 0.0
303− , pageLoad: Milliseconds 300000.0
304− , script: Milliseconds 30000.0
305− }
306− requestMapRef ← R.liftEff $ Ref.newRef Map.empty
307− let input =
308− { timeoutsRef
309− , requestMapRef
310− , uri
311− , session
312− , capabilities
313− }
314− R.interpretRec (R.on _lunapark (handleLunapark input) R.send) a
360+performActions ∷ ∀ r. LT.ActionRequest → WithLunapark r Unit
361+performActions req = liftLunapark $ PerformActions req unit
362+
363+releaseActions ∷ ∀ r. WithLunapark r Unit
364+releaseActions = liftLunapark $ ReleaseActions unit
365+
366+runLunapark ∷ ∀ e r. HandleLunaparkInput → BaseRun e (lunapark ∷ LUNAPARK|r) ~> BaseRun e r
367+runLunapark input = do
368+ R.interpretRec (R.on _lunapark (handleLunapark input) R.send)
369+
370+runLunaparkActions ∷ ∀ e r. HandleLunaparkInput → Lunapark e r ~> BaseRun e (lunapark ∷ LUNAPARK|r)
371+runLunaparkActions input =
372+ if input.actionsEnabled
373+ then interpretW3CActions input SM.empty
374+ else R.interpretRec (R.on _lunaparkActions (jsonWireActions input) R.send)
375+
376+interpretW3CActions
377+ ∷ ∀ e r
378+ . HandleLunaparkInput
379+ → LT.ActionRequest
380+ → Lunapark e r
381+ ~> BaseRun e (lunapark ∷ LUNAPARK|r)
382+interpretW3CActions inp acc as = case R.peel as of
383+ Left la → case tag la of
384+ Left a → w3cActions acc (interpretW3CActions inp) a
385+ Right others → do
386+ performActions acc
387+ cont ← R.send others
388+ interpretW3CActions inp SM.empty cont
389+ Right a → pure a
390+ where
391+ tag = R.on _lunaparkActions Left Right
392+
393+w3cActions
394+ ∷ ∀ e r a
395+ . LT.ActionRequest
396+ → ( LT.ActionRequest
397+ → Lunapark e r
398+ ~> BaseRun e (lunapark ∷ LUNAPARK|r)
399+ )
400+ → ActionF (Lunapark e r a)
401+ → BaseRun e (lunapark ∷ LUNAPARK|r) a
402+w3cActions acc loop = case _ of
403+ Click btn next → loop acc next
404+ ButtonDown btn next → loop acc next
405+ ButtonUp btn next → loop acc next
406+ DoubleClick next → loop acc next
407+ MoveTo move next → loop acc next
408+ SendKeys txt next → loop acc next
409+ Pause ms next → loop acc next
410+ Touch tch → case tch of
411+ Tap next → loop acc next
412+ TouchDown next → loop acc next
413+ TouchUp next → loop acc next
414+ LongClick next → loop acc next
415+ Flick next → loop acc next
416+ Scroll next → loop acc next
417+ DoubleTap next → loop acc next
315418
316419type HandleLunaparkInput =
317420 { session ∷ LT.SessionId
@@ -319,9 +422,67 @@ type HandleLunaparkInput =
319422 , requestMapRef ∷ Ref.Ref (Map.Map String Boolean)
320423 , uri ∷ String
321424 , capabilities ∷ Array LT.Capability
425+ , actionsEnabled ∷ Boolean
322426 }
323427
324−handleLunapark ∷ ∀ e r. HandleLunaparkInput → LunaparkF ~> BaseRun r e
428+jsonWireActions ∷ ∀ e r. HandleLunaparkInput → ActionF ~> BaseRun e (lunapark ∷ LUNAPARK|r)
429+jsonWireActions inp = case _ of
430+ Click btn next → do
431+ _ ← post (LP.Click : Nil) (LT.encodeButton btn)
432+ pure next
433+ ButtonDown btn next → do
434+ _ ← post (LP.ButtonDown : Nil) (LT.encodeButton btn)
435+ pure next
436+ ButtonUp btn next → do
437+ _ ← post (LP.ButtonUp : Nil) (LT.encodeButton btn)
438+ pure next
439+ DoubleClick next → do
440+ _ ← post_ (LP.DoubleClick : Nil)
441+ pure next
442+ SendKeys txt next → do
443+ _ ← post (LP.Keys : Nil) (LT.encodeSendKeysRequest txt)
444+ pure next
445+ MoveTo move next → do
446+ element ← case move.origin of
447+ LT.FromViewport → map Just $ findElement $ LT.ByTagName "body"
448+ LT.FromPointer → pure Nothing
449+ LT.FromElement el → pure $ Just el
450+ let req = { xoffset: move.x, yoffset: move.y, element }
451+ _ ← post (LP.MoveTo : Nil) (LT.encodeMoveToRequest req)
452+ pure next
453+ Pause ms next → do
454+ R.liftAff $ Aff.delay ms
455+ pure next
456+ Touch tch → case tch of
457+ Tap next → do
458+ _ ← post_ (LP.Touch : LP.Click : Nil)
459+ pure next
460+ TouchDown next → do
461+ _ ← post_ (LP.Touch : LP.Down : Nil)
462+ pure next
463+ TouchUp next → do
464+ _ ← post_ (LP.Touch : LP.Up : Nil)
465+ pure next
466+ LongClick next → do
467+ _ ← post_ (LP.Touch : LP.LongClick : Nil)
468+ pure next
469+ Flick next → do
470+ _ ← post_ (LP.Touch : LP.Flick : Nil)
471+ pure next
472+ Scroll next → do
473+ _ ← post_ (LP.Touch : LP.Scroll : Nil)
474+ pure next
475+ DoubleTap next → do
476+ _ ← post_ (LP.Touch : LP.DoubleClick : Nil)
477+ pure next
478+ where
479+ post a b = liftAndRethrow $ LP.post inp.uri (inSession : a) b
480+ post_ a = liftAndRethrow $ LP.post_ inp.uri (inSession : a)
481+
482+ inSession ∷ LP.EndpointPart
483+ inSession = LP.InSession inp.session
484+
485+handleLunapark ∷ ∀ e r. HandleLunaparkInput → LunaparkF ~> BaseRun e r
325486handleLunapark inp = case _ of
326487 Quit next → do
327488 _ ← delete $ inSession : Nil
@@ -478,6 +639,15 @@ handleLunapark inp = case _ of
478639 GetActiveElement cont → do
479640 res ← get (inSession : LP.Element : LP.Active : Nil)
480641 map cont $ throwLeft $ LT.decodeElement res
642+ PerformActions req next → do
643+ when inp.actionsEnabled
644+ $ void $ post
645+ (inSession : LP.Actions : Nil)
646+ (LT.encodeActionRequest req)
647+ pure next
648+ ReleaseActions next → do
649+ when inp.actionsEnabled $ void $ delete (inSession : LP.Actions : Nil)
650+ pure next
481651 OnElement el elF →
482652 let inElement = LP.InElement el
483653 in case elF of
@@ -529,7 +699,7 @@ handleLunapark inp = case _ of
529699 ClearEl next → do
530700 _ ← post_ (inSession : inElement : LP.Clear : Nil)
531701 pure next
532− SendKeys txt next → do
702+ SendKeysEl txt next → do
533703 _ ← post (inSession : inElement : LP.Value : Nil) (LT.encodeSendKeysRequest txt)
534704 pure next
535705 IsDisplayed cont → do
@@ -547,14 +717,13 @@ handleLunapark inp = case _ of
547717 _ ← post_ (inSession : inElement : LP.Submit : Nil)
548718 pure next
549719
550−
551720 where
552721 delete a = liftAndRethrow $ LP.delete inp.uri a
553722 post a b = liftAndRethrow $ LP.post inp.uri a b
554723 get a = liftAndRethrow $ LP.get inp.uri a
555724 post_ a = liftAndRethrow $ LP.post_ inp.uri a
556725
557− withFallback ∷ ∀ a. String → { w3c ∷ BaseRun r e a, jsonWire ∷ BaseRun r e a } → BaseRun r e a
726+ withFallback ∷ ∀ a. String → { w3c ∷ BaseRun e r a, jsonWire ∷ BaseRun e r a } → BaseRun e r a
558727 withFallback key { w3c: try, jsonWire: fallback } = do
559728 mp ← R.liftEff $ Ref.readRef inp.requestMapRef
560729 case Map.lookup key mp of
@@ -575,489 +744,14 @@ handleLunapark inp = case _ of
575744 inSession ∷ LP.EndpointPart
576745 inSession = LP.InSession inp.session
577746
578− liftAndRethrow ∷ ∀ e ω. Aff (LunaparkEffects e) (Either LE.Error ω) → BaseRun r e ω
579− liftAndRethrow a = do
580− res ← R.liftAff a
581− RE.rethrow res
747+liftAndRethrow ∷ ∀ e r ω. Aff (LunaparkEffects e) (Either LE.Error ω) → BaseRun e r ω
748+liftAndRethrow a = do
749+ res ← R.liftAff a
750+ RE.rethrow res
582751
583− throwLeft ∷ ∀ ω. Either String ω → BaseRun r e ω
584− throwLeft = RE.rethrow <<< lmap LE.unknownError
752+throwLeft ∷ ∀ e r. Either String ~> BaseRun e r
753+throwLeft = RE.rethrow <<< lmap LE.unknownError
585754
586755-- Safe, since we actually want handler and result have same rows not, remove except
587756catch ∷ ∀ e r a. R.Run (except ∷ EXCEPT e|r) a → (e → R.Run (except ∷ EXCEPT e|r) a) → R.Run (except ∷ EXCEPT e|r) a
588757catch = unsafeCoerce $ flip RE.catch
589−
590−
591−--interpret ∷ ∀ e. LunaparkF ~> Aff (ajax ∷ AJAX|e)
592−--interpret = unsafeCoerce
593−
594−
595−{-
596−import Prelude
597−
598−
599−
600−
601−
602−
603−
604−import Debug.Trace as DT
605−
606−type Config =
607− { session ∷ LT.SessionId
608− , baseURI ∷ String
609− , capabilities ∷ Array LT.Capability
610− }
611−
612−type State =
613− { timeouts ∷ LT.Timeouts }
614−
615−type LunaparkConstraints e m a
616− = MonadError LE.Error m
617− ⇒ MonadAff (ajax ∷ AJAX|e) m
618− ⇒ MonadAsk Config m
619− ⇒ MonadState State m
620− ⇒ a
621−
622−rethrow
623− ∷ ∀ m e eff a
624− . MonadThrow e m
625− ⇒ MonadAff eff m
626− ⇒ Aff eff (Either e a)
627− → m a
628−rethrow a = liftAff a >>= either throwError pure
629−
630−wrapEither ∷ ∀ m a. MonadThrow LE.Error m ⇒ Either String a → m a
631−wrapEither = either (throwError <<< LE.unknownError) pure
632−
633−init
634− ∷ ∀ e m
635− . MonadAff (ajax ∷ AJAX|e) m
636− ⇒ String
637− → LT.CapabilitiesRequest
638− → m (Either LE.Error LT.CreateSessionResponse)
639−init uri desiredCapabilities = do
640− sessObj ← liftAff $ LA.init uri $ LT.encodeCapabilitiesRequest desiredCapabilities
641− pure $ sessObj >>= \a → lmap LE.unknownError (LT.decodeCreateSessionResponse a)
642−
643−quit ∷ ∀ e m. LunaparkConstraints e m (m Unit)
644−quit = do
645− r ← ask
646− void $ rethrow $ LA.quit r.baseURI $ un LT.SessionId r.session
647−
648−status ∷ ∀ e m. LunaparkConstraints e m (m LT.ServerStatus)
649−status = do
650− r ← ask
651− res ← rethrow $ LA.status r.baseURI
652− wrapEither $ LT.decodeServerStatus res
653−
654−getTimeouts ∷ ∀ e m. LunaparkConstraints e m (m LT.Timeouts)
655−getTimeouts = do
656− r ← ask
657− res ← rethrow $ LA.getTimeouts r.baseURI $ un LT.SessionId r.session
658− wrapEither $ LT.decodeTimeouts res
659−
660−setTimeouts ∷ ∀ e m. LunaparkConstraints e m (LT.Timeouts → m Unit)
661−setTimeouts timeouts = do
662− r ← ask
663− void $ rethrow $ LA.setTimeouts
664− r.baseURI
665− (un LT.SessionId r.session)
666− (LT.encodeTimeouts timeouts)
667−
668−go ∷ ∀ e m. LunaparkConstraints e m (String → m Unit)
669−go url = do
670− r ← ask
671− void $ rethrow $ LA.go
672− r.baseURI
673− (un LT.SessionId r.session)
674− (LT.encodeGoRequest url)
675−
676−getCurrentUrl ∷ ∀ e m. LunaparkConstraints e m (m String)
677−getCurrentUrl = do
678− r ← ask
679− res ← rethrow $ LA.getCurrentUrl r.baseURI $ un LT.SessionId r.session
680− wrapEither $ J.decodeJson res
681−
682−back ∷ ∀ e m. LunaparkConstraints e m (m Unit)
683−back = do
684− r ← ask
685− void $ rethrow $ LA.back r.baseURI $ un LT.SessionId r.session
686−
687−forward ∷ ∀ e m. LunaparkConstraints e m (m Unit)
688−forward = do
689− r ← ask
690− void $ rethrow $ LA.forward r.baseURI $ un LT.SessionId r.session
691−
692−refresh ∷ ∀ e m. LunaparkConstraints e m (m Unit)
693−refresh = do
694− r ← ask
695− void $ rethrow $ LA.refresh r.baseURI $ un LT.SessionId r.session
696−
697−getTitle ∷ ∀ e m. LunaparkConstraints e m (m String)
698−getTitle = do
699− r ← ask
700− res ← rethrow $ LA.getTitle r.baseURI $ un LT.SessionId r.session
701− wrapEither $ J.decodeJson res
702−
703−getWindowHandle ∷ ∀ e m. LunaparkConstraints e m (m LT.WindowHandle)
704−getWindowHandle = do
705− r ← ask
706− res ← rethrow $ LA.getWindowHandle r.baseURI $ un LT.SessionId r.session
707− wrapEither $ LT.decodeWindowHandle res
708−
709−closeWindow ∷ ∀ e m. LunaparkConstraints e m (m Unit)
710−closeWindow = do
711− r ← ask
712− void $ rethrow $ LA.closeWindow r.baseURI $ un LT.SessionId r.session
713−
714−switchToWindow ∷ ∀ e m. LunaparkConstraints e m (LT.WindowHandle → m Unit)
715−switchToWindow wh = do
716− r ← ask
717− void $ rethrow $ LA.switchToWindow
718− r.baseURI
719− (un LT.SessionId r.session)
720− (LT.encodeSwitchToWindowRequest wh)
721−
722−getWindowHandles ∷ ∀ e m. LunaparkConstraints e m (m (Array LT.WindowHandle))
723−getWindowHandles = do
724− r ← ask
725− res ← rethrow $ LA.getWindowHandles r.baseURI $ un LT.SessionId r.session
726− wrapEither $ T.traverse LT.decodeWindowHandle =<< J.decodeJson res
727−
728−switchToFrame ∷ ∀ e m. LunaparkConstraints e m (LT.FrameId → m Unit)
729−switchToFrame fid = do
730− r ← ask
731− void $ rethrow $ LA.switchToFrame
732− r.baseURI
733− (un LT.SessionId r.session)
734− (LT.encodeFrameId fid)
735−
736−switchToParentFrame ∷ ∀ e m. LunaparkConstraints e m (m Unit)
737−switchToParentFrame = do
738− r ← ask
739− void $ rethrow $ LA.switchToParentFrame r.baseURI $ un LT.SessionId r.session
740−
741−getWindowRect ∷ ∀ e m. LunaparkConstraints e m (m LT.Rectangle)
742−getWindowRect = do
743− r ← ask
744− res ← rethrow $ LA.getWindowRect r.baseURI $ un LT.SessionId r.session
745− wrapEither $ LT.decodeRectangle res
746−
747−setWindowRect ∷ ∀ e m. LunaparkConstraints e m (LT.Rectangle → m Unit)
748−setWindowRect rectangle = do
749− r ← ask
750− void $ rethrow $ LA.setWindowRect
751− r.baseURI
752− (un LT.SessionId r.session)
753− (LT.encodeRectangle rectangle)
754−
755−maximizeWindow ∷ ∀ e m. LunaparkConstraints e m (m Unit)
756−maximizeWindow = do
757− r ← ask
758− void $ rethrow $ LA.maximizeWindow r.baseURI $ un LT.SessionId r.session
759−
760−minimizeWindow ∷ ∀ e m. LunaparkConstraints e m (m Unit)
761−minimizeWindow = do
762− r ← ask
763− void $ rethrow $ LA.minimizeWindow r.baseURI $ un LT.SessionId r.session
764−
765−fullscreenWindow ∷ ∀ e m. LunaparkConstraints e m (m Unit)
766−fullscreenWindow = do
767− r ← ask
768− void $ rethrow $ LA.fullscreenWindow r.baseURI $ un LT.SessionId r.session
769−
770−findElement ∷ ∀ m e. LunaparkConstraints e m (LT.Locator → m LT.Element)
771−findElement loc = do
772− r ← ask
773− res ←
774− rethrow $ LA.findElement
775− r.baseURI
776− (un LT.SessionId r.session)
777− (LT.encodeLocator loc)
778− wrapEither $ LT.decodeElement res
779−
780−findElements ∷ ∀ m e. LunaparkConstraints e m (LT.Locator → m (Array LT.Element))
781−findElements loc = do
782− r ← ask
783− res ←
784− rethrow $ LA.findElements
785− r.baseURI
786− (un LT.SessionId r.session)
787− (LT.encodeLocator loc)
788− wrapEither $ T.traverse LT.decodeElement =<< J.decodeJson res
789−
790−findElementFromElement
791− ∷ ∀ m e
792− . LunaparkConstraints e m
793− ( LT.Element
794− → LT.Locator
795− → m LT.Element
796− )
797−findElementFromElement el loc = do
798− r ← ask
799− res ←
800− rethrow $ LA.findElementFromElement
801− r.baseURI
802− (un LT.SessionId r.session)
803− (un LT.Element el)
804− (LT.encodeLocator loc)
805− wrapEither $ LT.decodeElement res
806−
807−findElementsFromElement
808− ∷ ∀ m e
809− . LunaparkConstraints e m
810− ( LT.Element
811− → LT.Locator
812− → m (Array LT.Element)
813− )
814−findElementsFromElement el loc = do
815− r ← ask
816− res ←
817− rethrow $ LA.findElementsFromElement
818− r.baseURI
819− (un LT.SessionId r.session)
820− (un LT.Element el)
821− (LT.encodeLocator loc)
822− wrapEither $ T.traverse LT.decodeElement =<< J.decodeJson res
823−
824−getActiveElement ∷ ∀ m e. LunaparkConstraints e m (m LT.Element)
825−getActiveElement = do
826− r ← ask
827− res ← rethrow $ LA.getActiveElement r.baseURI $ un LT.SessionId r.session
828− wrapEither $ LT.decodeElement res
829−
830−isElementSelected ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m Boolean)
831−isElementSelected el = do
832− r ← ask
833− res ←
834− rethrow $ LA.isElementSelected
835− r.baseURI
836− (un LT.SessionId r.session)
837− (un LT.Element el)
838− wrapEither $ J.decodeJson res
839−
840−getElementAttribute ∷ ∀ m e. LunaparkConstraints e m (LT.Element → String → m (Maybe String))
841−getElementAttribute el attrName = do
842− r ← ask
843− res ←
844− rethrow $ LA.getElementAttribute
845− r.baseURI
846− (un LT.SessionId r.session)
847− (un LT.Element el)
848− attrName
849− if J.isNull res
850− then pure Nothing
851− else wrapEither $ J.decodeJson res
852−
853−getElementProperty ∷ ∀ m e. LunaparkConstraints e m (LT.Element → String → m J.Json)
854−getElementProperty el propName = do
855− r ← ask
856− rethrow $ LA.getElementProperty
857− r.baseURI
858− (un LT.SessionId r.session)
859− (un LT.Element el)
860− propName
861−
862−getElementCSSValue ∷ ∀ m e. LunaparkConstraints e m (LT.Element → String → m String)
863−getElementCSSValue el cssName = do
864− r ← ask
865− res ←
866− rethrow $ LA.getElementCSSValue
867− r.baseURI
868− (un LT.SessionId r.session)
869− (un LT.Element el)
870− cssName
871− wrapEither $ J.decodeJson res
872−
873−getElementText ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m String)
874−getElementText el = do
875− r ← ask
876− res ←
877− rethrow $ LA.getElementText
878− r.baseURI
879− (un LT.SessionId r.session)
880− (un LT.Element el)
881− wrapEither $ J.decodeJson res
882−
883−getElementTagName ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m String)
884−getElementTagName el = do
885− r ← ask
886− res ←
887− rethrow $ LA.getElementTagName
888− r.baseURI
889− (un LT.SessionId r.session)
890− (un LT.Element el)
891− wrapEither $ J.decodeJson res
892−
893−getElementRect ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m LT.Rectangle)
894−getElementRect el = do
895− r ← ask
896− res ←
897− rethrow $ LA.getElementRect
898− r.baseURI
899− (un LT.SessionId r.session)
900− (un LT.Element el)
901− wrapEither $ LT.decodeRectangle res
902−
903−isElementEnabled ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m Boolean)
904−isElementEnabled el = do
905− r ← ask
906− res ←
907− rethrow $ LA.isElementEnabled
908− r.baseURI
909− (un LT.SessionId r.session)
910− (un LT.Element el)
911− wrapEither $ J.decodeJson res
912−
913−elementClick ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m Unit)
914−elementClick el = do
915− r ← ask
916− void $ rethrow $ LA.elementClick
917− r.baseURI
918− (un LT.SessionId r.session)
919− (un LT.Element el)
920−
921−elementClear ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m Unit)
922−elementClear el = do
923− r ← ask
924− void $ rethrow $ LA.elementClear
925− r.baseURI
926− (un LT.SessionId r.session)
927− (un LT.Element el)
928−
929−elementSendKeys ∷ ∀ m e. LunaparkConstraints e m (LT.Element → String → m Unit)
930−elementSendKeys el txt = do
931− r ← ask
932− void $ rethrow $ LA.elementSendKeys
933− r.baseURI
934− (un LT.SessionId r.session)
935− (un LT.Element el)
936− (LT.encodeSendKeysRequest txt)
937−
938−getPageSource ∷ ∀ m e. LunaparkConstraints e m (m String)
939−getPageSource = do
940− r ← ask
941− res ← rethrow $ LA.getPageSource r.baseURI (un LT.SessionId r.session)
942− wrapEither $ J.decodeJson res
943−
944−executeScript ∷ ∀ m e. LunaparkConstraints e m (LT.Script → m J.Json)
945−executeScript scr = do
946− r ← ask
947− rethrow $ LA.executeScript
948− r.baseURI
949− (un LT.SessionId r.session)
950− (LT.encodeScript scr)
951−
952−executeAsyncScript ∷ ∀ m e. LunaparkConstraints e m (LT.Script → m J.Json)
953−executeAsyncScript scr = do
954− r ← ask
955− rethrow $ LA.executeAsyncScript
956− r.baseURI
957− (un LT.SessionId r.session)
958− (LT.encodeScript scr)
959−
960−getAllCookies ∷ ∀ m e. LunaparkConstraints e m (m (Array LT.Cookie))
961−getAllCookies = do
962− r ← ask
963− res ← rethrow $ LA.getAllCookies r.baseURI $ un LT.SessionId r.session
964− wrapEither $ T.traverse LT.decodeCookie =<< J.decodeJson res
965−
966−getNamedCookie ∷ ∀ m e. LunaparkConstraints e m (String → m LT.Cookie)
967−getNamedCookie name = do
968− r ← ask
969− res ← rethrow $ LA.getNamedCookie r.baseURI (un LT.SessionId r.session) name
970− wrapEither $ LT.decodeCookie res
971−
972−addCookie ∷ ∀ m e. LunaparkConstraints e m (LT.Cookie → m Unit)
973−addCookie cookie = do
974− r ← ask
975− void $ rethrow $ LA.addCookie
976− r.baseURI
977− (un LT.SessionId r.session)
978− (LT.encodeCookie cookie)
979−
980−deleteCookie ∷ ∀ m e. LunaparkConstraints e m (String → m Unit)
981−deleteCookie name = do
982− r ← ask
983− void $ rethrow $ LA.deleteCookie
984− r.baseURI
985− (un LT.SessionId r.session)
986− name
987−
988−deleteAllCookies ∷ ∀ m e. LunaparkConstraints e m (m Unit)
989−deleteAllCookies = do
990− r ← ask
991− void $ rethrow $ LA.deleteAllCookies r.baseURI $ un LT.SessionId r.session
992−
993−performActions ∷ ∀ m e. LunaparkConstraints e m (LT.ActionRequest → m Unit)
994−performActions req = do
995− r ← ask
996− void $ rethrow $ LA.performActions
997− r.baseURI
998− (un LT.SessionId r.session)
999− (DT.spy $ LT.encodeActionRequest req)
1000−
1001−releaseActions ∷ ∀ m e. LunaparkConstraints e m (m Unit)
1002−releaseActions = do
1003− r ← ask
1004− void $ rethrow $ LA.releaseActions r.baseURI $ un LT.SessionId r.session
1005−
1006−dismissAlert ∷ ∀ m e. LunaparkConstraints e m (m Unit)
1007−dismissAlert = do
1008− r ← ask
1009− void $ rethrow $ LA.dismissAlert r.baseURI $ un LT.SessionId r.session
1010−
1011−acceptAlert ∷ ∀ m e. LunaparkConstraints e m (m Unit)
1012−acceptAlert = do
1013− r ← ask
1014− void $ rethrow $ LA.acceptAlert r.baseURI $ un LT.SessionId r.session
1015−
1016−getAlertText ∷ ∀ m e. LunaparkConstraints e m (m String)
1017−getAlertText = do
1018− r ← ask
1019− res ← rethrow $ LA.getAlertText r.baseURI $ un LT.SessionId r.session
1020− wrapEither $ J.decodeJson res
1021−
1022−sendAlertText ∷ ∀ m e. LunaparkConstraints e m (String → m Unit)
1023−sendAlertText s = do
1024− r ← ask
1025− void $ rethrow $ LA.sendAlertText
1026− r.baseURI
1027− (un LT.SessionId r.session)
1028− (LT.encodeSendKeysRequest s)
1029−
1030−takeScreenshot ∷ ∀ m e. LunaparkConstraints e m (m LT.Screenshot)
1031−takeScreenshot = do
1032− r ← ask
1033− res ← rethrow $ LA.takeScreenshot
1034− r.baseURI
1035− (un LT.SessionId r.session)
1036− wrapEither $ LT.decodeScreenshot res
1037−
1038−takeElementScreenshot ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m LT.Screenshot)
1039−takeElementScreenshot el = do
1040− r ← ask
1041− res ← rethrow $ LA.takeElementScreenshot
1042− r.baseURI
1043− (un LT.SessionId r.session)
1044− (un LT.Element el)
1045− wrapEither $ LT.decodeScreenshot res
1046−
1047−-- Recomended by W3C
1048−isDisplayed ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m Boolean)
1049−isDisplayed el = do
1050− r ← ask
1051− res ← rethrow $ LA.isDisplayed
1052− r.baseURI
1053− (un LT.SessionId r.session)
1054− (un LT.Element el)
1055− wrapEither $ J.decodeJson res
1056−
1057−-- JsonWire legacy
1058−setWireTimeouts ∷ ∀ m e. LunaparkConstraints e m (LT.Timeouts → m Unit)
1059−setWireTimeouts ts = do
1060− r ← ask
1061− T.for_ (LT.encodeLegacyTimeouts ts) \j →
1062− void $ rethrow $ LA.setTimeouts r.baseURI (un LT.SessionId r.session) j
1063−-}