git.iko.soy/rowtype-yoga/purescript-lunapark
on main help sign in
...
6335fd6Maxim Zimaliev
bower.json+3−1
compare with main
unifiedsplit
@@ -6,6 +6,8 @@
6 "purescript-codec-argonaut": "^5.0.0",
6 "purescript-codec-argonaut": "^5.0.0",
7 "purescript-argonaut": "^3.1.0",
7 "purescript-argonaut": "^3.1.0",
8 "purescript-css": "^3.4.0",
8 "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"
10 }
12 }
11}
13}
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
4
4
5import Control.Monad.Aff (Aff)
5import Control.Monad.Aff (Aff)
6import Control.Monad.Aff.Class (class MonadAff, liftAff)
6import Control.Monad.Aff.Class (class MonadAff, liftAff)
7−import Control.Monad.Error.Class (class MonadThrow, throwError)
7+import Control.Monad.Error.Class (class MonadThrow, class MonadError, throwError)
8−import Control.Monad.Reader.Class (class MonadAsk, ask, asks)
8+import Control.Monad.Reader.Class (class MonadAsk, ask)
9+import Control.Monad.State.Class (class MonadState)
9import Data.Argonaut as J
10import Data.Argonaut as J
11+import Data.Bifunctor (lmap)
10import Data.Either (Either, either)
12import Data.Either (Either, either)
11import Data.Maybe (Maybe(..))
13import Data.Maybe (Maybe(..))
12import Data.Newtype (un)
14import Data.Newtype (un)
@@ -16,16 +18,22 @@ import Lunapark.Error as LE
16import Lunapark.Types as LT
18import Lunapark.Types as LT
17import Network.HTTP.Affjax (AJAX)
19import Network.HTTP.Affjax (AJAX)
18
20
21+import Debug.Trace (traceAnyM)
22+
19type Config =
23type Config =
20 { session ∷ LT.SessionId
24 { session ∷ LT.SessionId
21 , baseURI ∷ String
25 , baseURI ∷ String
22− , capabilities ∷ LT.Capabilities
26+ , capabilities ∷ Array LT.Capability
23 }
27 }
24
28
29+type State =
30+ { timeouts ∷ LT.Timeouts }
31+
25type LunaparkConstraints e m a
32type LunaparkConstraints e m a
26− = MonadThrow LE.Error m
33+ = MonadError LE.Error m
27 ⇒ MonadAff (ajax ∷ AJAX|e) m
34 ⇒ MonadAff (ajax ∷ AJAX|e) m
28 ⇒ MonadAsk Config m
35 ⇒ MonadAsk Config m
36+ ⇒ MonadState State m
29 ⇒ a
37 ⇒ a
30
38
31rethrow
39rethrow
@@ -39,19 +47,15 @@ rethrow a = liftAff a >>= either throwError pure
39wrapEither ∷ ∀ m a. MonadThrow LE.Error m ⇒ Either String a → m a
47wrapEither ∷ ∀ m a. MonadThrow LE.Error m ⇒ Either String a → m a
40wrapEither = either (throwError <<< LE.unknownError) pure
48wrapEither = either (throwError <<< LE.unknownError) pure
41
49
42−getSession ∷ ∀ m r. MonadAsk { session ∷ LT.SessionId |r } m ⇒ m LT.SessionId
43−getSession = asks _.session
44−
45init
50init
46 ∷ ∀ e m
51 ∷ ∀ e m
47 . MonadAff (ajax ∷ AJAX|e) m
52 . MonadAff (ajax ∷ AJAX|e) m
48− ⇒ MonadThrow LE.Error m
49 ⇒ String
53 ⇒ String
50− → LT.Capabilities
54+ → LT.CapabilitiesRequest
51− → m LT.CreateSessionResponse
55+ → m (Either LE.Error LT.CreateSessionResponse)
52init uri desiredCapabilities = do
56init uri desiredCapabilities = do
53− sessObj ← rethrow $ LA.init (uri <> "/session") $ LT.encodeCapabilities desiredCapabilities
57+ sessObj ← liftAff $ LA.init uri $ LT.encodeCapabilitiesRequest desiredCapabilities
54− wrapEither $ LT.decodeCreateSessionResponse sessObj
58+ pure $ sessObj >>= \a → lmap LE.unknownError (LT.decodeCreateSessionResponse a)
55
59
56quit ∷ ∀ e m. LunaparkConstraints e m (m Unit)
60quit ∷ ∀ e m. LunaparkConstraints e m (m Unit)
57quit = do
61quit = do
@@ -403,9 +407,13 @@ deleteAllCookies = do
403 r ← ask
407 r ← ask
404 void $ rethrow $ LA.deleteAllCookies r.baseURI $ un LT.SessionId r.session
408 void $ rethrow $ LA.deleteAllCookies r.baseURI $ un LT.SessionId r.session
405
409
406−{-
410+performActions ∷ ∀ m e. LunaparkConstraints e m (LT.ActionRequest → m Unit)
411+performActions req = do
412+ r ← ask
407−performActions
413+ void $ rethrow $ LA.performActions
408−-}
414+ r.baseURI
415+ (un LT.SessionId r.session)
416+ (LT.encodeActionRequest req)
409
417
410releaseActions ∷ ∀ m e. LunaparkConstraints e m (m Unit)
418releaseActions ∷ ∀ m e. LunaparkConstraints e m (m Unit)
411releaseActions = do
419releaseActions = do
@@ -447,8 +455,25 @@ takeScreenshot = do
447takeElementScreenshot ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m LT.Screenshot)
455takeElementScreenshot ∷ ∀ m e. LunaparkConstraints e m (LT.Element → m LT.Screenshot)
448takeElementScreenshot el = do
456takeElementScreenshot el = do
449 r ← ask
457 r ← ask
450− res ← rethrow LA.takeElementScreenshot
458+ res ← rethrow $ traceAnyM =<< LA.takeElementScreenshot
451 r.baseURI
459 r.baseURI
452 (un LT.SessionId r.session)
460 (un LT.SessionId r.session)
453 (un LT.Element el)
461 (un LT.Element el)
454 wrapEither $ LT.decodeScreenshot res
462 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)
12import Network.HTTP.Affjax as N
12import Network.HTTP.Affjax as N
13import Network.HTTP.StatusCode (StatusCode(..))
13import Network.HTTP.StatusCode (StatusCode(..))
14import Lunapark.Error as LE
14import Lunapark.Error as LE
15+import Debug.Trace (traceAnyM)
15
16
16-- | This two type synonims are used only here
17-- | This two type synonims are used only here
17-- | this is the lowest level of bindings this lib provides
18-- | this is the lowest level of bindings this lib provides
@@ -239,4 +240,14 @@ takeScreenshot uri sessId =
239
240
240takeElementScreenshot ∷ ∀ e. URI → SessionId → ElementId → Aff (ajax ∷ AJAX|e) (Either LE.Error Json)
241takeElementScreenshot ∷ ∀ e. URI → SessionId → ElementId → Aff (ajax ∷ AJAX|e) (Either LE.Error Json)
241takeElementScreenshot uri sessId elId =
242takeElementScreenshot 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
2+
3+import Prelude
4+
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
2+
3+import Prelude
4+
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
2
2
3import Prelude
3import Prelude
4
4
5−import Control.Alt ((<|>))
6−import CSS.Selector as CSS
7import CSS.Render as CSSR
5import CSS.Render as CSSR
6+import CSS.Selector as CSS
7+import Control.Alt ((<|>))
8import Data.Argonaut (Json, (.?))
8import Data.Argonaut (Json, (.?))
9import Data.Argonaut as J
9import Data.Argonaut as J
10import Data.Array as A
10import Data.Array as A
11−import Data.Foldable as F
12−import Data.Time.Duration (Milliseconds(..))
13import Data.Either (Either(..))
11import Data.Either (Either(..))
12+import Data.Traversable as F
13+import Data.Map as Map
14import Data.Maybe (Maybe(..))
14import Data.Maybe (Maybe(..))
15import Data.Newtype (class Newtype, un)
15import Data.Newtype (class Newtype, un)
16import Data.StrMap as SM
16import Data.StrMap as SM
17+import Data.String as Str
18+import Data.Time.Duration (Milliseconds(..))
17import Data.Tuple (Tuple(..))
19import Data.Tuple (Tuple(..))
20+import Data.Variant as V
18import Data.XPath.Types as X
21import Data.XPath.Types as X
19import Node.Encoding as NE
22import Node.Encoding as NE
20−import Unsafe.Coerce (unsafeCoerce)
23+import Node.Path (FilePath)
21
24
22newtype SessionId = SessionId String
25newtype SessionId = SessionId String
23derive instance newtypeSessionId ∷ Newtype SessionId _
26derive instance newtypeSessionId ∷ Newtype SessionId _
@@ -40,20 +43,12 @@ encodeElement (Element eid) = J.encodeJson $ SM.fromFoldable
40 , Tuple "ELEMENT" eid
43 , Tuple "ELEMENT" eid
41 ]
44 ]
42
45
43−data Capabilities
44−
45−encodeCapabilities ∷ Capabilities → Json
46−encodeCapabilities = unsafeCoerce
47−
48−decodeCapabilities ∷ Json → Either String Capabilities
49−decodeCapabilities js = Left "unimplemented"
50−
51decodeSessionId ∷ Json → Either String SessionId
46decodeSessionId ∷ Json → Either String SessionId
52decodeSessionId = map SessionId <<< J.decodeJson
47decodeSessionId = map SessionId <<< J.decodeJson
53
48
54type CreateSessionResponse =
49type CreateSessionResponse =
55 { session ∷ SessionId
50 { session ∷ SessionId
56− , capabilities ∷ Capabilities
51+ , capabilities ∷ Array Capability
57 }
52 }
58
53
59decodeCreateSessionResponse ∷ Json → Either String CreateSessionResponse
54decodeCreateSessionResponse ∷ Json → Either String CreateSessionResponse
@@ -90,6 +85,13 @@ encodeTimeouts r = J.encodeJson $ SM.fromFoldable
90 , Tuple "implicit" (un Milliseconds r.implicit)
85 , Tuple "implicit" (un Milliseconds r.implicit)
91 ]
86 ]
92
87
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+
93encodeGoRequest ∷ String → Json
95encodeGoRequest ∷ String → Json
94encodeGoRequest url = J.encodeJson $ SM.fromFoldable [ Tuple "url" url ]
96encodeGoRequest url = J.encodeJson $ SM.fromFoldable [ Tuple "url" url ]
95
97
@@ -136,6 +138,12 @@ data Locator
136 | ByTagName String
138 | ByTagName String
137 | ByLinkText String
139 | ByLinkText String
138 | ByPartialLinkText String
140 | ByPartialLinkText String
141+ | Raw RawLocator
142+
143+type RawLocator =
144+ { using ∷ String
145+ , value ∷ String
146+ }
139
147
140encodeLocator ∷ Locator → Json
148encodeLocator ∷ Locator → Json
141encodeLocator l = J.encodeJson $ SM.fromFoldable case l of
149encodeLocator l = J.encodeJson $ SM.fromFoldable case l of
@@ -159,6 +167,10 @@ encodeLocator l = J.encodeJson $ SM.fromFoldable case l of
159 [ Tuple "using" "tag name"
167 [ Tuple "using" "tag name"
160 , Tuple "value" sel
168 , Tuple "value" sel
161 ]
169 ]
170+ Raw r →
171+ [ Tuple "using" r.using
172+ , Tuple "value" r.value
173+ ]
162
174
163encodeSendKeysRequest ∷ String → Json
175encodeSendKeysRequest ∷ String → Json
164encodeSendKeysRequest txt = J.encodeJson $ SM.fromFoldable [ Tuple "text" txt ]
176encodeSendKeysRequest txt = J.encodeJson $ SM.fromFoldable [ Tuple "text" txt ]
@@ -231,3 +243,221 @@ type Screenshot =
231decodeScreenshot ∷ Json → Either String Screenshot
243decodeScreenshot ∷ Json → Either String Screenshot
232decodeScreenshot j =
244decodeScreenshot j =
233 { content: _, encoding: NE.Base64 } <$> J.decodeJson j
245 { 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
3import Prelude
3import Prelude
4
4
5import Control.Monad.Eff (Eff)
5import Control.Monad.Eff (Eff)
6+import Control.Monad.Eff.Class (liftEff)
6import Control.Monad.Aff as Aff
7import 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
7import Data.Foldable (for_)
16import Data.Foldable (for_)
8−import Data.Either (Either(..))
17+import Data.Either (Either(..), either)
9import Data.StrMap as SM
18import Data.StrMap as SM
19+import Data.Map as Map
10import Data.Argonaut as A
20import Data.Argonaut as A
11import Data.Tuple (Tuple(..))
21import Data.Tuple (Tuple(..))
12import Network.HTTP.Affjax as AJ
22import 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
13
28
14import Debug.Trace as DT
29import Debug.Trace as DT
15
30
16−main ∷ Eff _ Unit
31+import Lunapark.Starter as LS
17−main = void $ Aff.launchAff do
32+import Lunapark.Types as LT
18− res1 ← AJ.get "http://localhost:4444/wd/hub/status"
33+import Lunapark.API as LA
19− res2 ← AJ.post "http://localhost:4444/wd/hub/session" $ A.encodeJson $ SM.fromFoldable
34+import Lunapark.Helpers as LH
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− ]
39
35
40− DT.traceAnyA "ELEMENT "
36+defaultTimeouts ∷ LT.Timeouts
41− DT.traceAnyA $ res4.response ∷ A.Json
37+defaultTimeouts =
38+ { pageLoad: wrap 300000.0
39+ , implicit: wrap 0.0
40+ , script: wrap 30000.0
41+ }
42
42
43− res6 ← AJ.post ("http://localhost:4444/wd/hub/session/" <> sessId <> "/element") $ A.encodeJson $ SM.fromFoldable
43+main ∷ Eff _ Unit
44− [ Tuple "using" "css selector"
44+main = void $ Aff.launchAff do
45− , Tuple "value" "title "
45+ LS.start (Map.singleton LT.Chrome "ch.exe") "selenium-3.11.0.jar" [ ]
46− ]
47−
48− DT.traceAnyA "ELEMENT "
49− DT.traceAnyA $ res6.response ∷ A.Json
50−
51− DT.traceAnyA "========================================"
52
46
53− res5 ← AJ.delete ("http://localhost:4444/wd/hub/session/" <> sessId <> sessId)
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
54− DT.traceAnyA res5
51+ DT.traceAnyA "An error occured"
55− DT.traceAnyA $ res5.response ∷ A.Json
52+ DT.traceAnyA err
56
53
57− res5 ← AJ.delete ("http://localhost:4444/wd/hub/session/" <> sessId)
54+ Right sr → do
58− DT.traceAnyA res5
55+ let config = { session: sr.session, baseURI, capabilities: sr.capabilities }
59− DT.traceAnyA $ res5.response ∷ A.Json
56+ res ←
60
57
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 res1
61+ DT.traceAnyA "TS"
62− DT.traceAnyA $ res1.response ∷ String
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"
63− DT.traceAnyA res2
71+ DT.traceAnyA el
64− DT.traceAnyA $ res2.response ∷ A.Json
72+ DT.traceAnyA visible
73+ _ ← R.runBaseAff' $ R.runReader config $ R.runExcept $ R.runState { timeouts: defaultTimeouts } $ LA.quit
74+-- LA.quit
65− DT.traceAnyA "HEHEY!"
75+ DT.traceAnyA res
76+ void $ liftEff $ PR.exit 0 --CP.kill SIGTERM cp