6335fd6 · rowtype-yoga/purescript-lunapark

git.iko.soy/rowtype-yoga/purescript-lunapark

...

commit6335fd6ec243a0e9b99dc6c756b5add0507edd6d authorMaxim Zimaliev <zimaliev@gmail.com> dateFri 13 Apr 2018, 14:53 (9 years ago) parent0ee738b

9 files changed+503−78

compare with main

unifiedsplit

bower.json+3−1 ch.exe gk.exe src/Lunapark/API.purs+41−16 src/Lunapark/Affjax.purs+12−1 src/Lunapark/Helpers.purs+114 src/Lunapark/Starter.purs+32 src/Lunapark/Types.purs+244−14 src/Main.purs+57−46

bower.json+3−1

@@ -6,6 +6,8 @@

66 "purescript-codec-argonaut": "^5.0.0",

77 "purescript-argonaut": "^3.1.0",

88 "purescript-css": "^3.4.0",

9− "purescript-node-fs-aff": "^5.0.0"

9+ "purescript-node-fs-aff": "^5.0.0",

10+ "purescript-node-child-process": "^4.0.0",

11+ "purescript-node-process": "^5.0.0"

1012 }

1113}

ch.exenew file

Binary file not shown.

gk.exenew file

Binary file not shown.

src/Lunapark/API.purs+41−16

@@ -4,9 +4,11 @@ import Prelude

55import Control.Monad.Aff (Aff)

66import Control.Monad.Aff.Class (class MonadAff, liftAff)

7−import Control.Monad.Error.Class (class MonadThrow, throwError)

8−import Control.Monad.Reader.Class (class MonadAsk, ask, asks)

7+import Control.Monad.Error.Class (class MonadThrow, class MonadError, throwError)

8+import Control.Monad.Reader.Class (class MonadAsk, ask)

9+import Control.Monad.State.Class (class MonadState)

910import Data.Argonaut as J

11+import Data.Bifunctor (lmap)

1012import Data.Either (Either, either)

1113import Data.Maybe (Maybe(..))

1214import Data.Newtype (un)

@@ -16,16 +18,22 @@ import Lunapark.Error as LE

1618import Lunapark.Types as LT

1719import Network.HTTP.Affjax (AJAX)

1820

21+import Debug.Trace (traceAnyM)

22+

1923type Config =

2024 { session ∷ LT.SessionId

2125 , baseURI ∷ String

22− , capabilities ∷ LT.Capabilities

26+ , capabilities ∷ Array LT.Capability

2327 }

2428

29+type State =

30+ { timeouts ∷ LT.Timeouts }

31+

2532type LunaparkConstraints e m a

26− = MonadThrow LE.Error m

33+ = MonadError LE.Error m

2734 ⇒ MonadAff (ajax ∷ AJAX|e) m

2835 ⇒ MonadAsk Config m

36+ ⇒ MonadState State m

2937 ⇒ a

3038

3139rethrow

@@ -39,19 +47,15 @@ rethrow a = liftAff a >>= either throwError pure

3947wrapEither ∷ ∀ m a. MonadThrow LE.Error m ⇒ Either String a → m a

4048wrapEither = either (throwError <<< LE.unknownError) pure

4149

42−getSession ∷ ∀ m r. MonadAsk { session ∷ LT.SessionId |r } m ⇒ m LT.SessionId

43−getSession = asks _.session

44−

4550init

4651 ∷ ∀ e m

4752 . MonadAff (ajax ∷ AJAX|e) m

48− ⇒ MonadThrow LE.Error m

4953 ⇒ String

50− → LT.Capabilities

51− → m LT.CreateSessionResponse

54+ → LT.CapabilitiesRequest

55+ → m (Either LE.Error LT.CreateSessionResponse)

5256init uri desiredCapabilities = do

53− sessObj ← rethrow $ LA.init (uri <> "/session") $ LT.encodeCapabilities desiredCapabilities

54− wrapEither $ LT.decodeCreateSessionResponse sessObj

57+ sessObj ← liftAff $ LA.init uri $ LT.encodeCapabilitiesRequest desiredCapabilities

58+ pure $ sessObj >>= \a → lmap LE.unknownError (LT.decodeCreateSessionResponse a)

5559

5660quit ∷ ∀ e m. LunaparkConstraints e m (m Unit)

5761quit = do

@@ -403,9 +407,13 @@ deleteAllCookies = do

403407 r ← ask

404408 void $ rethrow $ LA.deleteAllCookies r.baseURI $ un LT.SessionId r.session

405409

406−{-

407−performActions

408−-}

410+performActions ∷ ∀ m e. LunaparkConstraints e m (LT.ActionRequest → m Unit)

411+performActions req = do

412+ r ← ask

413+ void $ rethrow $ LA.performActions

414+ r.baseURI

415+ (un LT.SessionId r.session)

416+ (LT.encodeActionRequest req)

409417

410418releaseActions ∷ ∀ m e. LunaparkConstraints e m (m Unit)

411419releaseActions = do

@@ -447,8 +455,25 @@ takeScreenshot = do

447455takeElementScreenshot ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m LT.Screenshot)

448456takeElementScreenshot el = do

449457 r ← ask

450− res ← rethrow LA.takeElementScreenshot

458+ res ← rethrow $ traceAnyM =<< LA.takeElementScreenshot

451459 r.baseURI

452460 (un LT.SessionId r.session)

453461 (un LT.Element el)

454462 wrapEither $ LT.decodeScreenshot res

463+

464+-- Recomended by W3C

465+isDisplayed ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m Boolean)

466+isDisplayed el = do

467+ r ← ask

468+ res ← rethrow $ LA.isDisplayed

469+ r.baseURI

470+ (un LT.SessionId r.session)

471+ (un LT.Element el)

472+ wrapEither $ J.decodeJson res

473+

474+-- JsonWire legacy

475+setWireTimeouts ∷ ∀ m e. LunaparkConstraints e m (LT.Timeouts → m Unit)

476+setWireTimeouts ts = do

477+ r ← ask

478+ T.for_ (LT.encodeLegacyTimeouts ts) \j →

479+ void $ rethrow $ LA.setTimeouts r.baseURI (un LT.SessionId r.session) j

src/Lunapark/Affjax.purs+12−1

@@ -12,6 +12,7 @@ import Network.HTTP.Affjax (AJAX)

1212import Network.HTTP.Affjax as N

1313import Network.HTTP.StatusCode (StatusCode(..))

1414import Lunapark.Error as LE

15+import Debug.Trace (traceAnyM)

1516

1617-- | This two type synonims are used only here

1718-- | this is the lowest level of bindings this lib provides

@@ -239,4 +240,14 @@ takeScreenshot uri sessId =

239240

240241takeElementScreenshot ∷ ∀ e. URI → SessionId → ElementId → Aff (ajax ∷ AJAX|e) (Either LE.Error Json)

241242takeElementScreenshot uri sessId elId =

242− map handleAPIError $ N.get (uri <> "/session/" <> sessId <> "/element/" <> elId <> "/screenshot")

243+ map handleAPIError $ traceAnyM =<< N.get (uri <> "/session/" <> sessId <> "/element/" <> elId <> "/screenshot")

244+

245+-- Recomended by W3C

246+isDisplayed ∷ ∀ e. URI → SessionId → ElementId → Aff (ajax ∷ AJAX|e) (Either LE.Error Json)

247+isDisplayed uri sessId elId = do

248+ map handleAPIError $ N.get (uri <> "/session/" <> sessId <> "/element/" <> elId <> "/displayed")

249+

250+-- JsonWire legacy

251+getSession ∷ ∀ e. URI → SessionId → Aff (ajax ∷ AJAX|e) (Either LE.Error Json)

252+getSession uri sessId =

253+ map handleAPIError $ N.get (uri <> "/session/" <> sessId)

src/Lunapark/Helpers.pursnew file+114

@@ -0,0 +1,114 @@

1+module Lunapark.Helpers where

3+import Prelude

5+import CSS as CSS

6+import Control.Monad.Aff as Aff

7+import Control.Monad.Aff.Class (liftAff)

8+import Control.Monad.Eff.Class (liftEff)

9+import Control.Monad.Eff.Ref as Ref

10+import Control.Monad.Error.Class as EC

11+import Control.Monad.State.Class as SC

12+import Data.Argonaut as J

13+import Data.Maybe (Maybe(..))

14+import Lunapark.API as LA

15+import Lunapark.Error as LE

16+import Lunapark.Types as LT

17+import Node.Buffer as B

18+import Node.FS (FileFlags(W))

19+import Node.FS.Aff as FS

20+import Node.Path as Path

21+

22+import Debug.Trace (traceAnyA)

23+

24+isVisible ∷ ∀ e m. LA.LunaparkConstraints e m (LT.Element → m Boolean)

25+isVisible el = EC.catchError (LA.isDisplayed el) \err → case err.error of

26+ LE.UnknownCommand → stepByStep

27+ e → EC.throwError err

28+ where

29+ script =

30+ { script: """var el = arguments[0]; return el.offsetHeight > 0 && el.offsetWidth > 0"""

31+ , args: [ LT.encodeElement el ]

32+ }

33+

34+ stepByStep = do

35+ res ← LA.executeScript script

36+ LA.wrapEither $ J.decodeJson res

37+

38+isStale ∷ ∀ e m. LA.LunaparkConstraints e m (LT.Element → m Boolean)

39+isStale el = EC.catchError (false <$ (LA.findElementsFromElement el $ LT.ByCss $ CSS.fromString "*")) \err →

40+ case err.error of

41+ LE.StaleElementReference → pure true

42+ _ → EC.throwError err

43+

44+setTimeouts ∷ ∀ e m. LA.LunaparkConstraints e m (LT.Timeouts → m Unit)

45+setTimeouts ts = EC.catchError (LA.setTimeouts ts) \err →

46+ case err.error of

47+ LE.InvalidArgument → do

48+ LA.setWireTimeouts ts

49+ SC.modify _{ timeouts = ts }

50+ _ → EC.throwError err

51+

52+getTimeouts ∷ ∀ e m. LA.LunaparkConstraints e m (m LT.Timeouts)

53+getTimeouts =

54+ EC.catchError action \err → case err.error of

55+ LE.UnknownCommand → do

56+ SC.gets _.timeouts

57+ _ → EC.throwError err

58+ where

59+ action = do

60+ ts ← LA.getTimeouts

61+ SC.modify _{ timeouts = ts }

62+ pure ts

63+

64+-- | Might be useful for setting implicit timeout of finding element

65+localTimeouts

66+ ∷ ∀ e m a

67+ . LA.LunaparkConstraints e m

68+ ( (LT.Timeouts → LT.Timeouts)

69+ → m a

70+ → m a

71+ )

72+localTimeouts fn action = do

73+ ts ← getTimeouts

74+ setTimeouts $ fn ts

75+ res ← action

76+ setTimeouts ts

77+ pure res

78+

79+-- | Currently used in ps-webdriver but with duration passed explicitly

80+-- | since we already have timeouts it might be good idea to use them

81+repeatedly ∷ ∀ e m a. LA.LunaparkConstraints (ref ∷ Ref.REF|e) m (m a → m a)

82+repeatedly action = do

83+ ts ← getTimeouts

84+ ref ← liftEff $ Ref.newRef false

85+ _ ← liftAff $ Aff.forkAff do

86+ Aff.delay ts.script

87+ liftEff $ Ref.writeRef ref true

88+ let attempt = EC.catchError action \e → do

89+ shouldRethrow ← liftEff $ Ref.readRef ref

90+ if shouldRethrow

91+ then EC.throwError e

92+ else do

93+ liftAff $ Aff.delay ts.implicit

94+ attempt

95+ attempt

96+

97+screenshot ∷ ∀ m e. LA.LunaparkConstraints (buffer ∷ B.BUFFER, fs ∷ FS.FS|e) m (Path.FilePath → m Unit)

98+screenshot fp = do

99+ res ← LA.takeScreenshot

100+ buffer ← liftEff $ B.fromString res.content res.encoding

101+ liftAff do

102+ FS.writeFile fp buffer

103+

104+elementScreenshot

105+ ∷ ∀ m e

106+ . LA.LunaparkConstraints (buffer ∷ B.BUFFER, fs ∷ FS.FS|e) m

107+ ( LT.Element → Path.FilePath → m Unit )

108+elementScreenshot el fp = do

109+ traceAnyA "ELEMENT SCREENSHOT"

110+ res ← LA.takeElementScreenshot el

111+ traceAnyA res

112+ buffer ← liftEff $ B.fromString res.content res.encoding

113+ liftAff do

114+ FS.writeFile fp buffer

src/Lunapark/Starter.pursnew file+32

@@ -0,0 +1,32 @@

1+module Lunapark.Starter where

3+import Prelude

5+import Control.Monad.Aff.Class (class MonadAff, liftAff)

6+import Control.Monad.Eff.Class (liftEff)

7+import Lunapark.Types as LT

8+import Data.Traversable as T

9+import Node.Path (FilePath)

10+import Node.FS (FS)

11+import Node.FS.Aff as FS

12+import Node.ChildProcess as CP

13+import Unsafe.Coerce (unsafeCoerce)

14+

15+start

16+ ∷ ∀ e m

17+ . MonadAff (fs ∷ FS, cp ∷ CP.CHILD_PROCESS|e) m

18+ ⇒ LT.DriverPaths

19+ → FilePath

20+ → Array String

21+ → m Unit

22+start drivers jarPath additionalParams = do

23+ preparedJar ← liftAff $ FS.realpath jarPath

24+ preparedDrivers ← liftAff $ T.traverse FS.realpath drivers

25+

26+ liftEff $ CP.execFile

27+ ("java "

28+ <> T.intercalate " " (LT.renderDriverPaths preparedDrivers)

29+ <> " -jar " <> preparedJar <> " "

30+ <> T.intercalate " " additionalParams)

31+ CP.defaultExecOptions

32+ (const $ pure unit)

src/Lunapark/Types.purs+244−14

@@ -2,22 +2,25 @@ module Lunapark.Types where

33import Prelude

5−import Control.Alt ((<|>))

6−import CSS.Selector as CSS

75import CSS.Render as CSSR

6+import CSS.Selector as CSS

7+import Control.Alt ((<|>))

88import Data.Argonaut (Json, (.?))

99import Data.Argonaut as J

1010import Data.Array as A

11−import Data.Foldable as F

12−import Data.Time.Duration (Milliseconds(..))

1311import Data.Either (Either(..))

12+import Data.Traversable as F

13+import Data.Map as Map

1414import Data.Maybe (Maybe(..))

1515import Data.Newtype (class Newtype, un)

1616import Data.StrMap as SM

17+import Data.String as Str

18+import Data.Time.Duration (Milliseconds(..))

1719import Data.Tuple (Tuple(..))

20+import Data.Variant as V

1821import Data.XPath.Types as X

1922import Node.Encoding as NE

20−import Unsafe.Coerce (unsafeCoerce)

23+import Node.Path (FilePath)

2124

2225newtype SessionId = SessionId String

2326derive instance newtypeSessionId ∷ Newtype SessionId _

@@ -40,20 +43,12 @@ encodeElement (Element eid) = J.encodeJson $ SM.fromFoldable

4043 , Tuple "ELEMENT" eid

4144 ]

4245

43−data Capabilities

44−

45−encodeCapabilities ∷ Capabilities → Json

46−encodeCapabilities = unsafeCoerce

47−

48−decodeCapabilities ∷ Json → Either String Capabilities

49−decodeCapabilities js = Left "unimplemented"

50−

5146decodeSessionId ∷ Json → Either String SessionId

5247decodeSessionId = map SessionId <<< J.decodeJson

5348

5449type CreateSessionResponse =

5550 { session ∷ SessionId

56− , capabilities ∷ Capabilities

51+ , capabilities ∷ Array Capability

5752 }

5853

5954decodeCreateSessionResponse ∷ Json → Either String CreateSessionResponse

@@ -90,6 +85,13 @@ encodeTimeouts r = J.encodeJson $ SM.fromFoldable

9085 , Tuple "implicit" (un Milliseconds r.implicit)

9186 ]

9287

88+encodeLegacyTimeouts ∷ Timeouts → Array Json

89+encodeLegacyTimeouts r =

90+ [ J.encodeJson $ SM.singleton "script" $ un Milliseconds r.script

91+ , J.encodeJson $ SM.singleton "implicit" $ un Milliseconds r.implicit

92+ , J.encodeJson $ SM.singleton "page load" $ un Milliseconds r.pageLoad

93+ ]

94+

9395encodeGoRequest ∷ String → Json

9496encodeGoRequest url = J.encodeJson $ SM.fromFoldable [ Tuple "url" url ]

9597

@@ -136,6 +138,12 @@ data Locator

136138 | ByTagName String

137139 | ByLinkText String

138140 | ByPartialLinkText String

141+ | Raw RawLocator

142+

143+type RawLocator =

144+ { using ∷ String

145+ , value ∷ String

146+ }

139147

140148encodeLocator ∷ Locator → Json

141149encodeLocator l = J.encodeJson $ SM.fromFoldable case l of

@@ -159,6 +167,10 @@ encodeLocator l = J.encodeJson $ SM.fromFoldable case l of

159167 [ Tuple "using" "tag name"

160168 , Tuple "value" sel

161169 ]

170+ Raw r →

171+ [ Tuple "using" r.using

172+ , Tuple "value" r.value

173+ ]

162174

163175encodeSendKeysRequest ∷ String → Json

164176encodeSendKeysRequest txt = J.encodeJson $ SM.fromFoldable [ Tuple "text" txt ]

@@ -231,3 +243,221 @@ type Screenshot =

231243decodeScreenshot ∷ Json → Either String Screenshot

232244decodeScreenshot j =

233245 { content: _, encoding: NE.Base64 } <$> J.decodeJson j

246+

247+data Button = LeftBtn | MiddleBtn | RightBtn

248+

249+encodeButton ∷ Button → Json

250+encodeButton = J.encodeJson <<< case _ of

251+ LeftBtn → 0

252+ MiddleBtn → 1

253+ RightBtn → 2

254+

255+data PointerMoveOrigin

256+ = FromViewport

257+ | FromPointer

258+ | FromElement Element

259+

260+encodeOrigin ∷ PointerMoveOrigin → Json

261+encodeOrigin = case _ of

262+ FromViewport → J.encodeJson "viewport"

263+ FromPointer → J.encodeJson "pointer"

264+ FromElement el → encodeElement el

265+

266+type PointerMove =

267+ { duration ∷ Milliseconds

268+ , origin ∷ PointerMoveOrigin

269+ , x ∷ Int

270+ , y ∷ Int

271+ }

272+

273+encodePointerMove ∷ PointerMove → Json

274+encodePointerMove r = J.encodeJson $ SM.fromFoldable

275+ [ Tuple "x" $ J.encodeJson r.x

276+ , Tuple "y" $ J.encodeJson r.y

277+ , Tuple "duration" $ J.encodeJson $ un Milliseconds r.duration

278+ , Tuple "origin" $ encodeOrigin r.origin

279+ ]

280+

281+

282+type Action = V.Variant

283+ ( pause ∷ Milliseconds

284+ , keyDown ∷ Char

285+ , keyUp ∷ Char

286+ , pointerUp ∷ Button

287+ , pointerDown ∷ Button

288+ , pointerMove ∷ PointerMove

289+ )

290+

291+encodeAction ∷ Action → Json

292+encodeAction = V.match

293+ { pause: \ms → J.encodeJson $ SM.singleton "duration" $ J.encodeJson $ un Milliseconds ms

294+ , keyDown: \ch → J.encodeJson $ SM.singleton "value" $ J.encodeJson ch

295+ , keyUp: \ch → J.encodeJson $ SM.singleton "value" $ J.encodeJson ch

296+ , pointerUp: \btn → J.encodeJson $ SM.singleton "button" $ encodeButton btn

297+ , pointerDown: \btn → J.encodeJson $ SM.singleton "button" $ encodeButton btn

298+ , pointerMove: encodePointerMove

299+ }

300+

301+

302+data PointerType = Mouse | Pen | Touch

303+

304+printPointerType ∷ PointerType → String

305+printPointerType = case _ of

306+ Mouse → "mouse"

307+ Pen → "pen"

308+ Touch → "touch"

309+

310+data ActionSequence

311+ = NoSource

312+ (Array (V.Variant (pause ∷ Milliseconds)))

313+ | Key

314+ (Array (V.Variant (keyDown ∷ Char, keyUp ∷ Char, pause ∷ Milliseconds)))

315+ | Pointer PointerType

316+ (Array (V.Variant (pause ∷ Milliseconds, pointerUp ∷ Button, pointerDown ∷ Button, pointerMove ∷ PointerMove)))

317+

318+-- Right, this is not an `Array` but `StrMap` because all `ActionSequence`s are tagged with unique id's

319+type ActionRequest = SM.StrMap ActionSequence

320+

321+encodeActionRequest ∷ ActionRequest → Json

322+encodeActionRequest sm = J.encodeJson $ SM.singleton "actions" $ map encodePair arrayOfPairs

323+ where

324+ arrayOfPairs ∷ Array (Tuple String ActionSequence)

325+ arrayOfPairs = SM.toUnfoldable sm

326+

327+ encodePair ∷ Tuple String ActionSequence → Json

328+ encodePair (Tuple identifier sequence) =

329+ J.encodeJson $ SM.insert "id" (J.encodeJson identifier) $ encodeSequence sequence

330+

331+ encodeSequence ∷ ActionSequence → J.JObject

332+ encodeSequence = case _ of

333+ NoSource as → SM.fromFoldable

334+ [ Tuple "type" $ J.encodeJson "none"

335+ , Tuple "actions" $ J.encodeJson $ map (encodeAction <<< V.expand) as

336+ ]

337+ Key as → SM.fromFoldable

338+ [ Tuple "type" $ J.encodeJson "key"

339+ , Tuple "actions" $ J.encodeJson $ map (encodeAction <<< V.expand) as

340+ ]

341+ Pointer ptype as → SM.fromFoldable

342+ [ Tuple "type" $ J.encodeJson "pointer"

343+ , Tuple "parameters" $ J.encodeJson $ SM.singleton "pointerType" $ printPointerType ptype

344+ , Tuple "actions" $ J.encodeJson $ map (encodeAction <<< V.expand) as

345+ ]

346+

347+data BrowserType

348+ = MSEdge

349+ | Chrome

350+ | Firefox

351+

352+derive instance eqBrowserType ∷ Eq BrowserType

353+derive instance ordBrowserType ∷ Ord BrowserType

354+

355+type DriverPaths = Map.Map BrowserType FilePath

356+

357+renderDriverPaths ∷ DriverPaths → Array String

358+renderDriverPaths ps = map renderDriverPath pairs

359+ where

360+ pairs ∷ Array (Tuple BrowserType String)

361+ pairs = Map.toUnfoldable ps

362+

363+ renderDriverPath ∷ Tuple BrowserType String → String

364+ renderDriverPath (Tuple br path) = renderBrowserProp br <> "=\"" <> path <> "\""

365+

366+ renderBrowserProp ∷ BrowserType → String

367+ renderBrowserProp = case _ of

368+ MSEdge → "-Dwebdriver.edge.driver"

369+ Chrome → "-Dwebdriver.chrome.driver"

370+ Firefox → "-DWebdriver.gecko.driver"

371+

372+

373+data PageLoad

374+ = Normal

375+ | Eager

376+ | Immediate

377+

378+data UnhandledPrompt = Accept | Dismiss

379+

380+data Platform = Windows | Mac | Linux | Any

381+

382+data Capability

383+ = BrowserName BrowserType

384+ | BrowserVersion String

385+ | PlatformName Platform

386+ | AcceptInsecureCerts Boolean

387+ | PageLoadStrategy PageLoad

388+ | DesiredTimeouts Timeouts

389+ | UnhandledPromptBehavior UnhandledPrompt

390+ | CustomCapability String Json

391+

392+

393+encodeCapability ∷ Capability → Tuple String Json

394+encodeCapability = case _ of

395+ BrowserName bn → Tuple "browserName" $ J.encodeJson case bn of

396+ MSEdge → "MicrosoftEdge"

397+ Chrome → "chrome"

398+ Firefox → "firefox"

399+ BrowserVersion bv → Tuple "browserVersion" $ J.encodeJson bv

400+ PlatformName pn → Tuple "platform" $ J.encodeJson case pn of

401+ Windows → "WINDOWS"

402+ Mac → "MAC"

403+ Linux → "LINUX"

404+ Any → "ANY"

405+ AcceptInsecureCerts b → Tuple "acceptInsecureCerts" $ J.encodeJson b

406+ PageLoadStrategy s → Tuple "pageLoadStrategy" $ J.encodeJson case s of

407+ Normal → "normal"

408+ Eager → "eager"

409+ Immediate → "none"

410+ DesiredTimeouts t → Tuple "timeouts" $ encodeTimeouts t

411+ UnhandledPromptBehavior p → Tuple "unhandledPromptBehavior" $ J.encodeJson case p of

412+ Accept → "accept"

413+ Dismiss → "dismiss"

414+ CustomCapability k v → Tuple k v

415+

416+encodeCapabilities ∷ ∀ f. F.Foldable f ⇒ f Capability → Json

417+encodeCapabilities = F.foldl (\b a → J.extend (encodeCapability a) b) J.jsonEmptyObject

418+

419+decodeCapabilities ∷ Json → Either String (Array Capability)

420+decodeCapabilities = J.decodeJson >=> \obj →

421+ F.for (SM.toUnfoldable obj) \l@(Tuple key val) →

422+ decodeCapability l <|> Right (CustomCapability key val)

423+ where

424+ decodeCapability ∷ Tuple String Json → Either String Capability

425+ decodeCapability (Tuple key val) = case key of

426+ "browserName" → BrowserName <$> decodeBrowserName val

427+ "browserVersion" → BrowserVersion <$> J.decodeJson val

428+ "acceptInsecureCerts" → AcceptInsecureCerts <$> J.decodeJson val

429+ "pageLoadStrategy" → PageLoadStrategy <$> decodePageLoadStrategy val

430+ "timeouts" → DesiredTimeouts <$> decodeTimeouts val

431+ "unhandledPromptBehaviour" → UnhandledPromptBehavior <$> decodePrompt val

432+ _ → Left "unhandled"

433+

434+ decodeBrowserName ∷ Json → Either String BrowserType

435+ decodeBrowserName = J.decodeJson >=> \str → case Str.toLower str of

436+ "microsoftedge" → Right MSEdge

437+ "chrome" → Right Chrome

438+ "firefox" → Right Firefox

439+ _ → Left "unhandled"

440+

441+ decodePageLoadStrategy ∷ Json → Either String PageLoad

442+ decodePageLoadStrategy = J.decodeJson >=> \str → case Str.toLower str of

443+ "none" → Right Immediate

444+ "normal" → Right Normal

445+ "eager" → Right Eager

446+ _ → Left "unhandled"

447+

448+ decodePrompt ∷ Json → Either String UnhandledPrompt

449+ decodePrompt = J.decodeJson >=> \str → case Str.toLower str of

450+ "accept" → Right Accept

451+ "dismiss" → Right Dismiss

452+ _ → Left "unhandled"

453+

454+type CapabilitiesRequest =

455+ { alwaysMatch ∷ Array Capability

456+ , firstMatch ∷ Array (Array Capability)

457+ }

458+

459+encodeCapabilitiesRequest ∷ CapabilitiesRequest → Json

460+encodeCapabilitiesRequest r = J.encodeJson $ SM.singleton "capabilities" $ SM.fromFoldable

461+ [ Tuple "alwaysMatch" $ encodeCapabilities r.alwaysMatch

462+ , Tuple "firstMatch" $ J.encodeJson $ map encodeCapabilities r.firstMatch

463+ ]

src/Main.purs+57−46

@@ -3,63 +3,74 @@ module Main where

33import Prelude

55import Control.Monad.Eff (Eff)

6+import Control.Monad.Eff.Class (liftEff)

67import Control.Monad.Aff as Aff

8+import Control.Monad.Except.Trans as ET

9+import Control.Monad.Reader.Trans as RT

10+import Control.Monad.State.Trans as ST

11+import Control.Comonad (class Comonad, extract)

12+import Control.Extend (class Extend, extend, (<<=), (=>>))

13+import Data.Newtype (wrap)

14+import CSS as CSS

15+import CSS.Selector as Selector

716import Data.Foldable (for_)

8−import Data.Either (Either(..))

17+import Data.Either (Either(..), either)

918import Data.StrMap as SM

19+import Data.Map as Map

1020import Data.Argonaut as A

1121import Data.Tuple (Tuple(..))

1222import Network.HTTP.Affjax as AJ

23+import Node.ChildProcess as CP

24+import Data.Posix.Signal (Signal(..))

25+import Control.Monad.Eff.Now as Now

26+import Run as R

27+import Node.Process as PR

1328

1429import Debug.Trace as DT

1530

16−main ∷ Eff _ Unit

17−main = void $ Aff.launchAff do

18− res1 ← AJ.get "http://localhost:4444/wd/hub/status"

19− res2 ← AJ.post "http://localhost:4444/wd/hub/session" $ A.encodeJson $ SM.fromFoldable

20− [ Tuple "desiredCapabilities" $ SM.fromFoldable [ Tuple "browserName" "MicrosoftEdge" ]

21− ]

22−

23− let

24− eitherSessionId ∷ Either String String

25− eitherSessionId = do

26− obj ← A.decodeJson res2.response

27− obj A..? "sessionId"

28−

29− for_ eitherSessionId \sessId → do

30− res3 ← AJ.post ("http://localhost:4444/wd/hub/session/" <> sessId <> "/url") $ A.encodeJson $ SM.fromFoldable

31− [ Tuple "url" "https://www.w3.org/TR/webdriver/" ]

32− DT.traceAnyA res3

33− DT.traceAnyA $ res3.response ∷ A.Json

34−

35− res4 ← AJ.post ("http://localhost:4444/wd/hub/session/" <> sessId <> "/element") $ A.encodeJson $ SM.fromFoldable

36− [ Tuple "using" "css selector"

37− , Tuple "value" "#respecDocument"

38− ]

31+import Lunapark.Starter as LS

32+import Lunapark.Types as LT

33+import Lunapark.API as LA

34+import Lunapark.Helpers as LH

3935

40− DT.traceAnyA "ELEMENT "

41− DT.traceAnyA $ res4.response ∷ A.Json

36+defaultTimeouts ∷ LT.Timeouts

37+defaultTimeouts =

38+ { pageLoad: wrap 300000.0

39+ , implicit: wrap 0.0

40+ , script: wrap 30000.0

41+ }

4242

43− res6 ← AJ.post ("http://localhost:4444/wd/hub/session/" <> sessId <> "/element") $ A.encodeJson $ SM.fromFoldable

44− [ Tuple "using" "css selector"

45− , Tuple "value" "title "

46− ]

47−

48− DT.traceAnyA "ELEMENT "

49− DT.traceAnyA $ res6.response ∷ A.Json

50−

51− DT.traceAnyA "========================================"

43+main ∷ Eff _ Unit

44+main = void $ Aff.launchAff do

45+ LS.start (Map.singleton LT.Chrome "ch.exe") "selenium-3.11.0.jar" [ ]

5246

53− res5 ← AJ.delete ("http://localhost:4444/wd/hub/session/" <> sessId <> sessId)

54− DT.traceAnyA res5

55− DT.traceAnyA $ res5.response ∷ A.Json

47+ let baseURI = "http://localhost:4444/wd/hub"

48+ ei ← LA.init baseURI { alwaysMatch: [ ], firstMatch: [ [ LT.BrowserName LT.Chrome ] ] }

49+ case ei of

50+ Left err → do

51+ DT.traceAnyA "An error occured"

52+ DT.traceAnyA err

5653

57− res5 ← AJ.delete ("http://localhost:4444/wd/hub/session/" <> sessId)

58− DT.traceAnyA res5

59− DT.traceAnyA $ res5.response ∷ A.Json

54+ Right sr → do

55+ let config = { session: sr.session, baseURI, capabilities: sr.capabilities }

56+ res ←

6057

61− DT.traceAnyA res1

62− DT.traceAnyA $ res1.response ∷ String

63− DT.traceAnyA res2

64− DT.traceAnyA $ res2.response ∷ A.Json

65− DT.traceAnyA "HEHEY!"

58+ R.runBaseAff' $ R.runReader config $ R.runExcept $ R.runState {timeouts: defaultTimeouts} do

59+-- flip RT.runReaderT config $ ET.runExceptT $ flip ST.runStateT { timeouts: defaultTimeouts } do

60+ LA.go "http://google.com"

61+ DT.traceAnyA "TS"

62+ LH.getTimeouts >>= DT.traceAnyA

63+ el ← LA.findElement $ LT.ByCss $ CSS.fromString "a"

64+ LH.setTimeouts { pageLoad: wrap 1000.0, script: wrap 10000.0, implicit: wrap 10000.0 }

65+ DT.traceAnyA =<< liftEff Now.now

66+ ts ← LH.getTimeouts

67+ DT.traceAnyA =<< liftEff Now.now

68+ visible ← LH.isVisible el

69+ LH.screenshot "./everything.png"

70+ LH.elementScreenshot el "./a.png"

71+ DT.traceAnyA el

72+ DT.traceAnyA visible

73+ _ ← R.runBaseAff' $ R.runReader config $ R.runExcept $ R.runState { timeouts: defaultTimeouts } $ LA.quit

74+-- LA.quit

75+ DT.traceAnyA res

76+ void $ liftEff $ PR.exit 0 --CP.kill SIGTERM cp