@@ -3,7 +3,10 @@ module Lunapark.API where
33import Prelude
44
55import Control.Monad.Rec.Class (class MonadRec)
6−import Data.Argonaut.Decode.Class as J
6+import Data.Argonaut.Decode.Class (decodeJson) as J
7+import Data.Argonaut.Encode.Class (encodeJson) as J
8+import Data.FoldableWithIndex as FI
9+import Data.Array as A
710import Data.Bifunctor (lmap)
811import Data.Either (Either(..), isRight)
912import Data.List (List(..), (:))
@@ -205,7 +208,7 @@ w3cActions acc loop = case _ of
205208type HandleLunaparkInput =
206209 { session ∷ LT.SessionId
207210 , timeoutsRef ∷ Ref.Ref LT.Timeouts
208− , requestMapRef ∷ Ref.Ref (Map.Map String Boolean)
211+ , requestMapRef ∷ Ref.Ref (Map.Map String Int)
209212 , uri ∷ String
210213 , capabilities ∷ Array LT.Capability
211214 , actionsEnabled ∷ Boolean
@@ -296,12 +299,11 @@ handleLunapark inp = case _ of
296299 pure $ cont res
297300 SetTimeouts ts next → do
298301 R.liftEffect $ Ref.write ts inp.timeoutsRef
299− withFallback "set timeouts"
300− { w3c: void $ post (inSession : LP.Timeouts : Nil) (LT.encodeTimeouts ts)
301− , jsonWire: do
302− T.for_ (LT.encodeLegacyTimeouts ts) \j →
303− void $ post (inSession : LP.Timeouts : Nil) j
304− }
302+ tryAndCache "set timeouts"
303+ [ void $ post (inSession : LP.Timeouts : Nil) (LT.encodeTimeouts ts)
304+ , do T.for_ (LT.encodeLegacyTimeouts ts) \j →
305+ void $ post (inSession : LP.Timeouts : Nil) j
306+ ]
305307 pure next
306308 GoTo uri next → do
307309 _ ← post (inSession : LP.Url : Nil) $ LT.encodeGoRequest uri
@@ -322,16 +324,16 @@ handleLunapark inp = case _ of
322324 res ← get (inSession : LP.Title : Nil)
323325 map cont $ throwLeft $ J.decodeJson res
324326 GetWindowHandle cont → do
325− res ← withFallback "get window handle"
326− { w3c: get (inSession : LP.Window : Nil)
327− , jsonWire: get (inSession : LP.WindowHandle : Nil)
328− }
327+ res ← tryAndCache "get window handle"
328+ [ get (inSession : LP.Window : Nil)
329+ , get (inSession : LP.WindowHandle : Nil)
330+ ]
329331 map cont $ throwLeft $ LT.decodeWindowHandle res
330332 GetWindowHandles cont → do
331− res ← withFallback "get window handles"
332− { w3c: get (inSession : LP.Window : LP.Handles : Nil)
333− , jsonWire: get (inSession : LP.WindowHandles : Nil)
334− }
333+ res ← tryAndCache "get window handles"
334+ [ get (inSession : LP.Window : LP.Handles : Nil)
335+ , get (inSession : LP.WindowHandles : Nil)
336+ ]
335337 map cont $ throwLeft $ T.traverse LT.decodeWindowHandle =<< J.decodeJson res
336338 CloseWindow next → do
337339 _ ← delete (inSession : LP.Window : Nil)
@@ -346,25 +348,21 @@ handleLunapark inp = case _ of
346348 _ ← post_ (inSession : LP.Frame : LP.Parent : Nil)
347349 pure next
348350 GetWindowRectangle cont → do
349− res ← withFallback "get window rectangle"
350− { w3c: do
351− res ← get (inSession : LP.Window : LP.Rect : Nil)
351+ res ← tryAndCache "get window rectangle"
352+ [ do res ← get (inSession : LP.Window : LP.Rect : Nil)
352353 throwLeft $ LT.decodeRectangle res
353− , jsonWire: do
354− position ← get (inSession : LP.Window : LP.Position : Nil)
354+ , do position ← get (inSession : LP.Window : LP.Position : Nil)
355355 size ← get (inSession : LP.Window : LP.Size : Nil)
356356 throwLeft $ LT.decodeRectangleLegacy { position, size }
357− }
357+ ]
358358 pure $ cont res
359359 SetWindowRectangle r next → do
360− withFallback "set window rectangle"
361− { w3c: do
362− void $ post (inSession : LP.Window : LP.Rect : Nil) (LT.encodeRectangle r)
363− , jsonWire: do
364− let js = LT.encodeRectangleLegacy r
360+ tryAndCache "set window rectangle"
361+ [ void $ post (inSession : LP.Window : LP.Rect : Nil) (LT.encodeRectangle r)
362+ , do let js = LT.encodeRectangleLegacy r
365363 _ ← post (inSession : LP.Window : LP.Size : Nil) js.size
366364 void $ post (inSession : LP.Window : LP.Position : Nil) js.position
367− }
365+ ]
368366 pure next
369367 MaximizeWindow next → do
370368 _ ← post_ (inSession : LP.Window : LP.Maximize : Nil)
@@ -376,15 +374,15 @@ handleLunapark inp = case _ of
376374 _ ← post_ (inSession : LP.Window : LP.Fullscreen : Nil)
377375 pure next
378376 ExecuteScript script cont → do
379− map cont $ withFallback "execute script"
380− { w3c: post (inSession : LP.Execute : LP.Sync : Nil) (LT.encodeScript script)
381− , jsonWire: post (inSession : LP.Execute : Nil) (LT.encodeScript script)
382− }
377+ map cont $ tryAndCache "execute script"
378+ [ post (inSession : LP.Execute : LP.Sync : Nil) (LT.encodeScript script)
379+ , post (inSession : LP.Execute : Nil) (LT.encodeScript script)
380+ ]
383381 ExecuteScriptAsync script cont → do
384− map cont $ withFallback "execute script async"
385− { w3c: post (inSession : LP.Execute : LP.Async : Nil) (LT.encodeScript script)
386− , jsonWire: post (inSession : LP.ExecuteAsync : Nil) (LT.encodeScript script)
387− }
382+ map cont $ tryAndCache "execute script async"
383+ [ post (inSession : LP.Execute : LP.Async : Nil) (LT.encodeScript script)
384+ , post (inSession : LP.ExecuteAsync : Nil) (LT.encodeScript script)
385+ ]
388386 GetAllCookies cont → do
389387 res ← get (inSession : LP.Cookies : Nil)
390388 map cont $ throwLeft $ T.traverse LT.decodeCookie =<< J.decodeJson res
@@ -401,28 +399,28 @@ handleLunapark inp = case _ of
401399 _ ← post (inSession : LP.Cookies : Nil) (LT.encodeCookie cookie)
402400 pure next
403401 DismissAlert next → do
404− _ ← withFallback "dismiss alert"
405− { w3c: post_ (inSession : LP.Alert : LP.Dismiss : Nil)
406− , jsonWire: post_ (inSession : LP.DismissAlert : Nil)
407− }
402+ _ ← tryAndCache "dismiss alert"
403+ [ post_ (inSession : LP.Alert : LP.Dismiss : Nil)
404+ , post_ (inSession : LP.DismissAlert : Nil)
405+ ]
408406 pure next
409407 AcceptAlert next → do
410− _ ← withFallback "accept alert"
411− { w3c: post_ (inSession : LP.Alert : LP.Accept : Nil)
412− , jsonWire: post_ (inSession : LP.AcceptAlert : Nil)
413− }
408+ _ ← tryAndCache "accept alert"
409+ [ post_ (inSession : LP.Alert : LP.Accept : Nil)
410+ , post_ (inSession : LP.AcceptAlert : Nil)
411+ ]
414412 pure next
415413 GetAlertText cont → do
416− res ← withFallback "get alert text"
417− { w3c: get (inSession : LP.Alert : LP.Text : Nil)
418− , jsonWire: get (inSession : LP.AlertText : Nil)
419− }
414+ res ← tryAndCache "get alert text"
415+ [ get (inSession : LP.Alert : LP.Text : Nil)
416+ , get (inSession : LP.AlertText : Nil)
417+ ]
420418 map cont $ throwLeft $ J.decodeJson res
421419 SendAlertText str next → do
422− _ ← withFallback "send alert text"
423− { w3c: post (inSession : LP.Alert : LP.Text : Nil) (LT.encodeSendKeysRequest str)
424− , jsonWire: post (inSession : LP.AlertText : Nil) (LT.encodeSendKeysRequest str)
425− }
420+ _ ← tryAndCache "send alert text"
421+ [ post (inSession : LP.Alert : LP.Text : Nil) (LT.encodeSendKeysRequest str)
422+ , post (inSession : LP.AlertText : Nil) (LT.encodeSendKeysRequest str)
423+ ]
426424 pure next
427425 Screenshot fp next → do
428426 res ← get (inSession : LP.Screenshot : Nil)
@@ -481,15 +479,13 @@ handleLunapark inp = case _ of
481479 res ← get (inSession : inElement : LP.Name : Nil)
482480 map cont $ throwLeft $ J.decodeJson res
483481 GetRectangle cont →
484− map cont $ withFallback "get element rectangle"
485− { w3c: do
486− res ← get (inSession : inElement : LP.Rect : Nil)
487− throwLeft $ LT.decodeRectangle res
488− , jsonWire: do
489− position ← get (inSession : inElement : LP.Position : Nil)
490− size ← get (inSession : inElement : LP.Size : Nil)
491− throwLeft $ LT.decodeRectangleLegacy { position, size }
492− }
482+ map cont $ tryAndCache "get element rectangle"
483+ [ do res ← get (inSession : inElement : LP.Rect : Nil)
484+ throwLeft $ LT.decodeRectangle res
485+ , do position ← get (inSession : inElement : LP.Position : Nil)
486+ size ← get (inSession : inElement : LP.Size : Nil)
487+ throwLeft $ LT.decodeRectangleLegacy { position, size }
488+ ]
493489 IsEnabled cont → do
494490 res ← get (inSession : inElement : LP.Enabled : Nil)
495491 map cont $ throwLeft $ J.decodeJson res
@@ -500,18 +496,21 @@ handleLunapark inp = case _ of
500496 _ ← post_ (inSession : inElement : LP.Clear : Nil)
501497 pure next
502498 SendKeysEl txt next → do
503− _ ← post (inSession : inElement : LP.Value : Nil) (LT.encodeSendKeysRequest txt)
499+ _ ← tryAndCache "send keys chromedriver hack"
500+ [ post (inSession : inElement : LP.Value : Nil) (LT.encodeSendKeysRequest txt)
501+ , post (inSession : inElement : LP.Value : Nil)
502+ $ J.encodeJson $ FO.singleton "value" $ Str.toCharArray txt
503+ ]
504504 pure next
505505 IsDisplayed cont → do
506− res ← withFallback "is element displayed"
507− { w3c: get (inSession : inElement : LP.Displayed : Nil)
508− , jsonWire: do
509− let script =
506+ res ← tryAndCache "is element displayed"
507+ [ get (inSession : inElement : LP.Displayed : Nil)
508+ , do let script =
510509 { script: """var el = arguments[0]; return el.offsetHeight > 0 && el.offsetWidth > 0"""
511510 , args: [ LT.encodeElement el ]
512511 }
513512 handleLunapark inp $ ExecuteScript script identity
514− }
513+ ]
515514 map cont $ throwLeft $ J.decodeJson res
516515 Submit next → do
517516 _ ← post_ (inSession : inElement : LP.Submit : Nil)
@@ -523,23 +522,26 @@ handleLunapark inp = case _ of
523522 get a = liftAndRethrow $ LP.get inp.uri a
524523 post_ a = liftAndRethrow $ LP.post_ inp.uri a
525524
526− withFallback ∷ ∀ a. String → { w3c ∷ BaseRun r a, jsonWire ∷ BaseRun r a } → BaseRun r a
527− withFallback key { w3c: try, jsonWire: fallback } = do
525+ tryAndCache ∷ ∀ a. String → Array (BaseRun r a) → BaseRun r a
526+ tryAndCache key actions = do
527+ let emptyCases = throwLeft $ Left $ "No valid cases for " <> key <> " caching"
528+ let incorrectCache = throwLeft $ Left $ "Fallback for " <> key <> " error"
529+
528530 mp ← R.liftEffect $ Ref.read inp.requestMapRef
529531 case Map.lookup key mp of
530− Just true → try
531− Just false → fallback
532+ Just ix → case A.index actions ix of
533+ Just action → action
534+ Nothing → incorrectCache
532535 Nothing →
533536 let
534− try' = do
535− a ← try
536− R.liftEffect $ Ref.modify_ (Map.insert key true) inp.requestMapRef
537− pure a
538− fallback' = do
539− a ← fallback
540− R.liftEffect $ Ref.modify_ (Map.insert key false) inp.requestMapRef
541− pure a
542− in catch try' \_ → fallback'
537+ go ix acc act =
538+ let try' = do
539+ a ← act
540+ R.liftEffect $ Ref.modify_ (Map.insert key ix) inp.requestMapRef
541+ pure a
542+ in catch try' \_ → acc
543+ in
544+ FI.foldlWithIndex go emptyCases actions
543545
544546 inSession ∷ LP.EndpointPart
545547 inSession = LP.InSession inp.session