git.iko.soy/rowtype-yoga/purescript-lunapark
on main help sign in
modules were rearranged
commit0bd2e65843f0abf67a9f672cdf7d4388d9855ad4 authorMaxim Zimaliev <zimaliev@gmail.com> dateMon 23 Apr 2018, 16:22 (8 years ago) parentf1b71ab
8 files changed+383−364
compare with main
unifiedsplit
src/Lunapark.purs+12 src/Lunapark/API.purs+12−326 src/Lunapark/ActionF.purs+80 src/Lunapark/Endpoint.purs+5−6 src/Lunapark/LunaparkF.purs+237 src/Lunapark/Types.purs+3 src/Lunapark/Utils.purs+34 src/Main.purs−32
src/Lunapark.pursnew file+12
@@ -0,0 +1,12 @@
1+module Lunapark
2+ ( module API
3+ , module Error
4+ , module ActionF
5+ , module LunaparkF
6+ ) where
7+
8+
9+import Lunapark.API as API
10+import Lunapark.Error as Error
11+import Lunapark.ActionF as ActionF
12+import Lunapark.LunaparkF as LunaparkF
src/Lunapark/API.purs+12−326
@@ -2,7 +2,6 @@ module Lunapark.API where
22
33import Prelude
44
5−import Control.Monad.Aff (Aff)
65import Control.Monad.Aff as Aff
76import Control.Monad.Aff.Class (class MonadAff, liftAff)
87import Control.Monad.Eff.Ref as Ref
@@ -15,7 +14,6 @@ import Data.List (List(..), (:))
1514import Data.List as L
1615import Data.Map as Map
1716import Data.Maybe (Maybe(..))
18−import Data.Symbol (SProxy(..))
1917import Data.StrMap as SM
2018import Data.String as Str
2119import Data.Variant as V
@@ -24,13 +22,14 @@ import Data.Traversable as T
2422import Lunapark.Endpoint as LP
2523import Lunapark.Error as LE
2624import Lunapark.Types as LT
25+import Lunapark.LunaparkF (_lunapark, LUNAPARK, ElementF(..), LunaparkF(..), performActions, findElement)
26+import Lunapark.ActionF (_lunaparkActions, LUNAPARK_ACTIONS, ActionF(..), TouchF(..))
27+import Lunapark.Utils (liftAndRethrow, throwLeft, catch)
2728import Network.HTTP.Affjax (AJAX)
2829import Node.Buffer as B
2930import Node.FS.Aff as FS
3031import Run as R
3132import Run.Except (EXCEPT)
32−import Run.Except as RE
33−import Unsafe.Coerce (unsafeCoerce)
3433
3534type LunaparkEffects e =
3635 ( ajax ∷ AJAX
@@ -101,88 +100,6 @@ interpret
101100 ~> BaseRun e r
102101interpret input = runLunapark input <<< runLunaparkActions input
103102
104−data LunaparkF a
105− = Quit a
106− | Status (LT.ServerStatus → a)
107− | GetTimeouts (LT.Timeouts → a)
108− | SetTimeouts LT.Timeouts a
109− | GoTo String a
110− | GetUrl (String → a)
111− | Forward a
112− | Back a
113− | Refresh a
114− | GetTitle (String → a)
115− | GetWindowHandle (LT.WindowHandle → a)
116− | GetWindowHandles (Array LT.WindowHandle → a)
117− | CloseWindow a
118− | SwitchToWindow LT.WindowHandle a
119− | SwitchToFrame LT.FrameId a
120− | SwitchToParentFrame a
121− | GetWindowRectangle (LT.Rectangle → a)
122− | SetWindowRectangle LT.Rectangle a
123− | MaximizeWindow a
124− | MinimizeWindow a
125− | FullscreenWindow a
126− | ExecuteScript LT.Script (J.Json → a)
127− | ExecuteScriptAsync LT.Script (J.Json → a)
128− | GetAllCookies (Array LT.Cookie → a)
129− | GetCookie String (LT.Cookie → a)
130− | DeleteCookie String a
131− | DeleteAllCookies a
132− | AddCookie LT.Cookie a
133− | DismissAlert a
134− | AcceptAlert a
135− | GetAlertText (String → a)
136− | SendAlertText String a
137− | Screenshot String a
138− | GetActiveElement (LT.Element → a)
139− | FindElement LT.Locator (LT.Element → a)
140− | FindElements LT.Locator (Array LT.Element → a)
141− | OnElement LT.Element (ElementF a)
142− | PerformActions LT.ActionRequest a
143− | ReleaseActions a
144−
145−data ElementF a
146− = ChildElement LT.Locator (LT.Element → a)
147− | ChildElements LT.Locator (Array LT.Element → a)
148− | IsSelected (Boolean → a)
149− | GetAttribute String (String → a)
150− | GetProperty String (J.Json → a)
151− | GetCss String (String → a)
152− | GetText (String → a)
153− | GetTagName (String → a)
154− | GetRectangle (LT.Rectangle → a)
155− | IsEnabled (Boolean → a)
156− | ClickEl a
157− | ClearEl a
158− | SendKeysEl String a
159− | ScreenshotEl String a
160− | IsDisplayed (Boolean → a)
161− | Submit a
162−
163−data ActionF a
164− = Click LT.Button a
165− | ButtonDown LT.Button a
166− | ButtonUp LT.Button a
167− | DoubleClick LT.Button a
168− | SendKeys String a
169− | MoveTo LT.PointerMove a
170− | Touch (TouchF a)
171− | Pause Milliseconds a
172−
173−data TouchF a
174− = Tap a
175− | TouchDown a
176− | TouchUp a
177− | LongClick a
178− | Flick LT.PointerMove a
179− | Scroll LT.PointerMove a
180− | DoubleTap a
181−
182−derive instance functorLunaparkF ∷ Functor LunaparkF
183−derive instance functorElementF ∷ Functor ElementF
184−derive instance functorActionF ∷ Functor ActionF
185−derive instance functorTouchF ∷ Functor TouchF
186103
187104type Lunapark e r = BaseRun e (lunapark ∷ LUNAPARK, lunaparkActions ∷ LUNAPARK_ACTIONS|r)
188105
@@ -192,246 +109,27 @@ type BaseRun e r = R.Run
192109 , eff ∷ R.EFF (LunaparkEffects e)
193110 | r)
194111
195−_lunapark = SProxy ∷ SProxy "lunapark"
196−type LUNAPARK = R.FProxy LunaparkF
197−type WithLunapark r a = R.Run (lunapark ∷ LUNAPARK|r) a
198−
199−liftLunapark ∷ ∀ a r. LunaparkF a → WithLunapark r a
200−liftLunapark = R.lift _lunapark
201−
202−quit ∷ ∀ r. WithLunapark r Unit
203−quit = liftLunapark $ Quit unit
204−
205−status ∷ ∀ r. WithLunapark r LT.ServerStatus
206−status = liftLunapark $ Status id
207−
208−setTimeouts ∷ ∀ r. LT.Timeouts → WithLunapark r Unit
209−setTimeouts ts = liftLunapark $ SetTimeouts ts unit
210−
211−getTimeouts ∷ ∀ r. WithLunapark r LT.Timeouts
212−getTimeouts = liftLunapark $ GetTimeouts id
213−
214−go ∷ ∀ r. String → WithLunapark r Unit
215−go uri = liftLunapark $ GoTo uri unit
216−
217−getUrl ∷ ∀ r. WithLunapark r String
218−getUrl = liftLunapark $ GetUrl id
219−
220−forward ∷ ∀ r. WithLunapark r Unit
221−forward = liftLunapark $ Forward unit
222−
223−back ∷ ∀ r. WithLunapark r Unit
224−back = liftLunapark $ Back unit
225−
226−refresh ∷ ∀ r. WithLunapark r Unit
227−refresh = liftLunapark $ Refresh unit
228−
229−getTitle ∷ ∀ r. WithLunapark r String
230−getTitle = liftLunapark $ GetTitle id
231−
232−getWindowHandle ∷ ∀ r. WithLunapark r LT.WindowHandle
233−getWindowHandle = liftLunapark $ GetWindowHandle id
234−
235−getWindowHandles ∷ ∀ r. WithLunapark r (Array LT.WindowHandle)
236−getWindowHandles = liftLunapark $ GetWindowHandles id
237−
238−closeWindow ∷ ∀ r. WithLunapark r Unit
239−closeWindow = liftLunapark $ CloseWindow unit
240−
241−switchToWindow ∷ ∀ r. LT.WindowHandle → WithLunapark r Unit
242−switchToWindow w = liftLunapark $ SwitchToWindow w unit
243−
244−switchToFrame ∷ ∀ r. LT.FrameId → WithLunapark r Unit
245−switchToFrame f = liftLunapark $ SwitchToFrame f unit
246−
247−switchToParentFrame ∷ ∀ r. WithLunapark r Unit
248−switchToParentFrame = liftLunapark $ SwitchToParentFrame unit
249−
250−getWindowRectangle ∷ ∀ r. WithLunapark r LT.Rectangle
251−getWindowRectangle = liftLunapark $ GetWindowRectangle id
252−
253−setWindowRectangle ∷ ∀ r. LT.Rectangle → WithLunapark r Unit
254−setWindowRectangle r = liftLunapark $ SetWindowRectangle r unit
255−
256−maximizeWindow ∷ ∀ r. WithLunapark r Unit
257−maximizeWindow = liftLunapark $ MaximizeWindow unit
258−
259−minimizeWindow ∷ ∀ r. WithLunapark r Unit
260−minimizeWindow = liftLunapark $ MinimizeWindow unit
261−
262−fullscreenWindow ∷ ∀ r. WithLunapark r Unit
263−fullscreenWindow = liftLunapark $ FullscreenWindow unit
264−
265−executeScript ∷ ∀ r. LT.Script → WithLunapark r J.Json
266−executeScript script = liftLunapark $ ExecuteScript script id
267−
268−executeScriptAsync ∷ ∀ r. LT.Script → WithLunapark r J.Json
269−executeScriptAsync script = liftLunapark $ ExecuteScriptAsync script id
270−
271−getAllCookies ∷ ∀ r. WithLunapark r (Array LT.Cookie)
272−getAllCookies = liftLunapark $ GetAllCookies id
273−
274−getCookie ∷ ∀ r. String → WithLunapark r LT.Cookie
275−getCookie name = liftLunapark $ GetCookie name id
276−
277−addCookie ∷ ∀ r. LT.Cookie → WithLunapark r Unit
278−addCookie cookie = liftLunapark $ AddCookie cookie unit
279−
280−deleteCookie ∷ ∀ r. String → WithLunapark r Unit
281−deleteCookie name = liftLunapark $ DeleteCookie name unit
282−
283−deleteAllCookies ∷ ∀ r. WithLunapark r Unit
284−deleteAllCookies = liftLunapark $ DeleteAllCookies unit
285−
286−dismissAlert ∷ ∀ r. WithLunapark r Unit
287−dismissAlert = liftLunapark $ DismissAlert unit
288−
289−acceptAlert ∷ ∀ r. WithLunapark r Unit
290−acceptAlert = liftLunapark $ AcceptAlert unit
291−
292−getAlertText ∷ ∀ r. WithLunapark r String
293−getAlertText = liftLunapark $ GetAlertText id
294−
295−sendAlertText ∷ ∀ r. String → WithLunapark r Unit
296−sendAlertText txt = liftLunapark $ SendAlertText txt unit
297−
298−screenshot ∷ ∀ r. String → WithLunapark r Unit
299−screenshot fp = liftLunapark $ Screenshot fp unit
300−
301−elementScreenshot ∷ ∀ r. LT.Element → String → WithLunapark r Unit
302−elementScreenshot el fp = liftLunapark $ OnElement el $ ScreenshotEl fp unit
303−
304−findElement ∷ ∀ r. LT.Locator → WithLunapark r LT.Element
305−findElement l = liftLunapark $ FindElement l id
306−
307−findElements ∷ ∀ r. LT.Locator → WithLunapark r (Array LT.Element)
308−findElements l = liftLunapark $ FindElements l id
309−
310−childElement ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r LT.Element
311−childElement el l = liftLunapark $ OnElement el $ ChildElement l id
312−
313−childElements ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r (Array LT.Element)
314−childElements el l = liftLunapark $ OnElement el $ ChildElements l id
315−
316−isSelected ∷ ∀ r. LT.Element → WithLunapark r Boolean
317−isSelected el = liftLunapark $ OnElement el $ IsSelected id
318−
319−getAttribute ∷ ∀ r. LT.Element → String → WithLunapark r String
320−getAttribute el name = liftLunapark $ OnElement el $ GetAttribute name id
321−
322−getProperty ∷ ∀ r. LT.Element → String → WithLunapark r J.Json
323−getProperty el name = liftLunapark $ OnElement el $ GetProperty name id
324−
325−getCss ∷ ∀ r. LT.Element → String → WithLunapark r String
326−getCss el name = liftLunapark $ OnElement el $ GetCss name id
327−
328−getText ∷ ∀ r. LT.Element → WithLunapark r String
329−getText el = liftLunapark $ OnElement el $ GetText id
330−
331−getTagName ∷ ∀ r. LT.Element → WithLunapark r String
332−getTagName el = liftLunapark $ OnElement el $ GetTagName id
333−
334−getRectangle ∷ ∀ r. LT.Element → WithLunapark r LT.Rectangle
335−getRectangle el = liftLunapark $ OnElement el $ GetRectangle id
336−
337−isEnabled ∷ ∀ r. LT.Element → WithLunapark r Boolean
338−isEnabled el = liftLunapark $ OnElement el $ IsEnabled id
339−
340−clickElement ∷ ∀ r. LT.Element → WithLunapark r Unit
341−clickElement el = liftLunapark $ OnElement el $ ClickEl unit
342−
343−clearElement ∷ ∀ r. LT.Element → WithLunapark r Unit
344−clearElement el = liftLunapark $ OnElement el $ ClearEl unit
345−
346−sendKeysElement ∷ ∀ r. LT.Element → String → WithLunapark r Unit
347−sendKeysElement el txt = liftLunapark $ OnElement el $ SendKeysEl txt unit
348−
349−isDisplayed ∷ ∀ r. LT.Element → WithLunapark r Boolean
350−isDisplayed el = liftLunapark $ OnElement el $ IsDisplayed id
351−
352−submitElement ∷ ∀ r. LT.Element → WithLunapark r Unit
353−submitElement el = liftLunapark $ OnElement el $ Submit unit
354−
355−performActions ∷ ∀ r. LT.ActionRequest → WithLunapark r Unit
356−performActions req = liftLunapark $ PerformActions req unit
357−
358−releaseActions ∷ ∀ r. WithLunapark r Unit
359−releaseActions = liftLunapark $ ReleaseActions unit
360−
361−-- ACTIONS
362−_lunaparkActions = SProxy ∷ SProxy "lunaparkActions"
363−type LUNAPARK_ACTIONS = R.FProxy ActionF
364−type WithAction r = R.Run (lunaparkActions ∷ LUNAPARK_ACTIONS|r) Unit
365−
366−liftAction ∷ ∀ r. ActionF Unit → WithAction r
367−liftAction = R.lift _lunaparkActions
368−
369−click ∷ ∀ r. LT.Button → WithAction r
370−click btn = liftAction $ Click btn unit
371−
372−buttonDown ∷ ∀ r. LT.Button → WithAction r
373−buttonDown btn = liftAction $ ButtonDown btn unit
374−
375−buttonUp ∷ ∀ r. LT.Button → WithAction r
376−buttonUp btn = liftAction $ ButtonUp btn unit
377−
378−doubleClick ∷ ∀ r. LT.Button → WithAction r
379−doubleClick btn = liftAction $ DoubleClick btn unit
380−
381−sendKeys ∷ ∀ r. String → WithAction r
382−sendKeys txt = liftAction $ SendKeys txt unit
383−
384−moveTo ∷ ∀ r. LT.PointerMove → WithAction r
385−moveTo move = liftAction $ MoveTo move unit
386−
387−pause ∷ ∀ r. Milliseconds → WithAction r
388−pause ms = liftAction $ Pause ms unit
389−
390−tap ∷ ∀ r. WithAction r
391−tap = liftAction $ Touch $ Tap unit
392−
393−touchDown ∷ ∀ r. WithAction r
394−touchDown = liftAction $ Touch $ TouchDown unit
395−
396−touchUp ∷ ∀ r. WithAction r
397−touchUp = liftAction $ Touch $ TouchUp unit
398−
399−longTap ∷ ∀ r. WithAction r
400−longTap = liftAction $ Touch $ LongClick unit
401−
402−flick ∷ ∀ r. LT.PointerMove → WithAction r
403−flick move = liftAction $ Touch $ Flick move unit
404−
405−scroll ∷ ∀ r. LT.PointerMove → WithAction r
406−scroll move = liftAction $ Touch $ Scroll move unit
407−
408−doubleTap ∷ ∀ r. WithAction r
409−doubleTap = liftAction $ Touch $ DoubleTap unit
410−
411−-- Interpreters
412112runLunapark ∷ ∀ e r. HandleLunaparkInput → BaseRun e (lunapark ∷ LUNAPARK|r) ~> BaseRun e r
413113runLunapark input = do
414114 R.interpretRec (R.on _lunapark (handleLunapark input) R.send)
415115
416116runLunaparkActions ∷ ∀ e r. HandleLunaparkInput → Lunapark e r ~> BaseRun e (lunapark ∷ LUNAPARK|r)
417−runLunaparkActions input =
418− if input.actionsEnabled
419− then interpretW3CActions input Nil
420− else R.interpretRec (R.on _lunaparkActions (jsonWireActions input) R.send)
117+runLunaparkActions input
118+ | input.actionsEnabled = interpretW3CActions Nil
119+ | otherwise = R.interpretRec (R.on _lunaparkActions (jsonWireActions input) R.send)
421120
422121interpretW3CActions
423122 ∷ ∀ e r
424− . HandleLunaparkInput
425− → List LT.ActionSequence
123+ . List LT.ActionSequence
426124 → Lunapark e r
427125 ~> BaseRun e (lunapark ∷ LUNAPARK|r)
428−interpretW3CActions inp acc as = case R.peel as of
126+interpretW3CActions acc as = case R.peel as of
429127 Left la → case tag la of
430− Left a → w3cActions acc (interpretW3CActions inp) a
128+ Left a → w3cActions acc interpretW3CActions a
431129 Right others → do
432130 T.for_ (L.reverse acc) \s → performActions $ SM.singleton "dummy" s
433131 cont ← R.send others
434− interpretW3CActions inp Nil cont
132+ interpretW3CActions Nil cont
435133 Right a → pure a
436134 where
437135 tag = R.on _lunaparkActions Left Right
@@ -467,7 +165,7 @@ w3cActions acc loop = case _ of
467165 Pause ms next →
468166 let seq = [ LT.pause ms ]
469167 in loop (anywhere seq) next
470− Touch tch → case tch of
168+ InTouch tch → case tch of
471169 Tap next →
472170 let seq = [ LT.pointerDown LT.LeftBtn, LT.pointerUp LT.LeftBtn ]
473171 in loop (inTouch seq) next
@@ -561,7 +259,7 @@ jsonWireActions inp = case _ of
561259 Pause ms next → do
562260 R.liftAff $ Aff.delay ms
563261 pure next
564− Touch tch → case tch of
262+ InTouch tch → case tch of
565263 Tap next → do
566264 _ ← post_ (LP.Touch : LP.Click : Nil)
567265 pure next
@@ -861,15 +559,3 @@ handleLunapark inp = case _ of
861559
862560 inSession ∷ LP.EndpointPart
863561 inSession = LP.InSession inp.session
864−
865−liftAndRethrow ∷ ∀ e r ω. Aff (LunaparkEffects e) (Either LE.Error ω) → BaseRun e r ω
866−liftAndRethrow a = do
867− res ← R.liftAff a
868− RE.rethrow res
869−
870−throwLeft ∷ ∀ e r. Either String ~> BaseRun e r
871−throwLeft = RE.rethrow <<< lmap LE.unknownError
872−
873−-- Safe, since we actually want handler and result have same rows not, remove except
874−catch ∷ ∀ 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
875−catch = unsafeCoerce $ flip RE.catch
src/Lunapark/ActionF.pursnew file+80
@@ -0,0 +1,80 @@
1+module Lunapark.ActionF where
2+
3+import Prelude
4+
5+import Data.Symbol (SProxy(..))
6+import Data.Time.Duration (Milliseconds)
7+import Lunapark.Types as LT
8+import Run as R
9+
10+
11+data ActionF a
12+ = Click LT.Button a
13+ | ButtonDown LT.Button a
14+ | ButtonUp LT.Button a
15+ | DoubleClick LT.Button a
16+ | SendKeys String a
17+ | MoveTo LT.PointerMove a
18+ | InTouch (TouchF a)
19+ | Pause Milliseconds a
20+
21+data TouchF a
22+ = Tap a
23+ | TouchDown a
24+ | TouchUp a
25+ | LongClick a
26+ | Flick LT.PointerMove a
27+ | Scroll LT.PointerMove a
28+ | DoubleTap a
29+
30+derive instance functorActionF ∷ Functor ActionF
31+derive instance functorTouchF ∷ Functor TouchF
32+
33+_lunaparkActions = SProxy ∷ SProxy "lunaparkActions"
34+type LUNAPARK_ACTIONS = R.FProxy ActionF
35+type WithAction r = R.Run (lunaparkActions ∷ LUNAPARK_ACTIONS|r) Unit
36+
37+liftAction ∷ ∀ r. ActionF Unit → WithAction r
38+liftAction = R.lift _lunaparkActions
39+
40+click ∷ ∀ r. LT.Button → WithAction r
41+click btn = liftAction $ Click btn unit
42+
43+buttonDown ∷ ∀ r. LT.Button → WithAction r
44+buttonDown btn = liftAction $ ButtonDown btn unit
45+
46+buttonUp ∷ ∀ r. LT.Button → WithAction r
47+buttonUp btn = liftAction $ ButtonUp btn unit
48+
49+doubleClick ∷ ∀ r. LT.Button → WithAction r
50+doubleClick btn = liftAction $ DoubleClick btn unit
51+
52+sendKeys ∷ ∀ r. String → WithAction r
53+sendKeys txt = liftAction $ SendKeys txt unit
54+
55+moveTo ∷ ∀ r. LT.PointerMove → WithAction r
56+moveTo move = liftAction $ MoveTo move unit
57+
58+pause ∷ ∀ r. Milliseconds → WithAction r
59+pause ms = liftAction $ Pause ms unit
60+
61+tap ∷ ∀ r. WithAction r
62+tap = liftAction $ InTouch $ Tap unit
63+
64+touchDown ∷ ∀ r. WithAction r
65+touchDown = liftAction $ InTouch $ TouchDown unit
66+
67+touchUp ∷ ∀ r. WithAction r
68+touchUp = liftAction $ InTouch $ TouchUp unit
69+
70+longTap ∷ ∀ r. WithAction r
71+longTap = liftAction $ InTouch $ LongClick unit
72+
73+flick ∷ ∀ r. LT.PointerMove → WithAction r
74+flick move = liftAction $ InTouch $ Flick move unit
75+
76+scroll ∷ ∀ r. LT.PointerMove → WithAction r
77+scroll move = liftAction $ InTouch $ Scroll move unit
78+
79+doubleTap ∷ ∀ r. WithAction r
80+doubleTap = liftAction $ InTouch $ DoubleTap unit
src/Lunapark/Endpoint.purs+5−6
@@ -1,3 +1,8 @@
1+-- | Building whole endpoint leads to having tons of noizy things like `ElementFindElement` and `TouchClick`
2+-- | Making this a `Variant` is definitely overkill
3+-- | So, to have something like `/session/:sessId/element/:elId/doubleclick` we have
4+-- | `InSession sessId : InElement elId : DoubleClick : Nil`
5+-- | This is not as typesafe as it could be, but at least it saves from typos.
16module Lunapark.Endpoint where
27
38import Prelude
@@ -17,12 +22,6 @@ import Network.HTTP.Affjax (AJAX)
1722import Network.HTTP.Affjax as N
1823import Network.HTTP.StatusCode (StatusCode(..))
1924
20−
21−-- | Building whole endpoint leads to having tons of noizy things like `ElementFindElement` and `TouchClick`
22−-- | Making this a `Variant` is definitely overkill
23−-- | So, to have something like `/session/:sessId/element/:elId/doubleclick` we have
24−-- | `InSession sessId : InElement elId : DoubleClick : Nil`
25−-- | This is not as typesafe as it could be, but at least it saves from typos.
2625data EndpointPart
2726 = Session
2827 | InSession LT.SessionId
src/Lunapark/LunaparkF.pursnew file+237
@@ -0,0 +1,237 @@
1+module Lunapark.LunaparkF where
2+
3+import Prelude
4+
5+import Data.Argonaut as J
6+import Data.Symbol (SProxy(..))
7+import Lunapark.Types as LT
8+import Run as R
9+
10+data LunaparkF a
11+ = Quit a
12+ | Status (LT.ServerStatus → a)
13+ | GetTimeouts (LT.Timeouts → a)
14+ | SetTimeouts LT.Timeouts a
15+ | GoTo String a
16+ | GetUrl (String → a)
17+ | Forward a
18+ | Back a
19+ | Refresh a
20+ | GetTitle (String → a)
21+ | GetWindowHandle (LT.WindowHandle → a)
22+ | GetWindowHandles (Array LT.WindowHandle → a)
23+ | CloseWindow a
24+ | SwitchToWindow LT.WindowHandle a
25+ | SwitchToFrame LT.FrameId a
26+ | SwitchToParentFrame a
27+ | GetWindowRectangle (LT.Rectangle → a)
28+ | SetWindowRectangle LT.Rectangle a
29+ | MaximizeWindow a
30+ | MinimizeWindow a
31+ | FullscreenWindow a
32+ | ExecuteScript LT.Script (J.Json → a)
33+ | ExecuteScriptAsync LT.Script (J.Json → a)
34+ | GetAllCookies (Array LT.Cookie → a)
35+ | GetCookie String (LT.Cookie → a)
36+ | DeleteCookie String a
37+ | DeleteAllCookies a
38+ | AddCookie LT.Cookie a
39+ | DismissAlert a
40+ | AcceptAlert a
41+ | GetAlertText (String → a)
42+ | SendAlertText String a
43+ | Screenshot String a
44+ | GetActiveElement (LT.Element → a)
45+ | FindElement LT.Locator (LT.Element → a)
46+ | FindElements LT.Locator (Array LT.Element → a)
47+ | OnElement LT.Element (ElementF a)
48+ | PerformActions LT.ActionRequest a
49+ | ReleaseActions a
50+
51+data ElementF a
52+ = ChildElement LT.Locator (LT.Element → a)
53+ | ChildElements LT.Locator (Array LT.Element → a)
54+ | IsSelected (Boolean → a)
55+ | GetAttribute String (String → a)
56+ | GetProperty String (J.Json → a)
57+ | GetCss String (String → a)
58+ | GetText (String → a)
59+ | GetTagName (String → a)
60+ | GetRectangle (LT.Rectangle → a)
61+ | IsEnabled (Boolean → a)
62+ | ClickEl a
63+ | ClearEl a
64+ | SendKeysEl String a
65+ | ScreenshotEl String a
66+ | IsDisplayed (Boolean → a)
67+ | Submit a
68+
69+derive instance functorLunaparkF ∷ Functor LunaparkF
70+derive instance functorElementF ∷ Functor ElementF
71+
72+_lunapark = SProxy ∷ SProxy "lunapark"
73+type LUNAPARK = R.FProxy LunaparkF
74+type WithLunapark r a = R.Run (lunapark ∷ LUNAPARK|r) a
75+
76+
77+liftLunapark ∷ ∀ a r. LunaparkF a → WithLunapark r a
78+liftLunapark = R.lift _lunapark
79+
80+quit ∷ ∀ r. WithLunapark r Unit
81+quit = liftLunapark $ Quit unit
82+
83+status ∷ ∀ r. WithLunapark r LT.ServerStatus
84+status = liftLunapark $ Status id
85+
86+setTimeouts ∷ ∀ r. LT.Timeouts → WithLunapark r Unit
87+setTimeouts ts = liftLunapark $ SetTimeouts ts unit
88+
89+getTimeouts ∷ ∀ r. WithLunapark r LT.Timeouts
90+getTimeouts = liftLunapark $ GetTimeouts id
91+
92+go ∷ ∀ r. String → WithLunapark r Unit
93+go uri = liftLunapark $ GoTo uri unit
94+
95+getUrl ∷ ∀ r. WithLunapark r String
96+getUrl = liftLunapark $ GetUrl id
97+
98+forward ∷ ∀ r. WithLunapark r Unit
99+forward = liftLunapark $ Forward unit
100+
101+back ∷ ∀ r. WithLunapark r Unit
102+back = liftLunapark $ Back unit
103+
104+refresh ∷ ∀ r. WithLunapark r Unit
105+refresh = liftLunapark $ Refresh unit
106+
107+getTitle ∷ ∀ r. WithLunapark r String
108+getTitle = liftLunapark $ GetTitle id
109+
110+getWindowHandle ∷ ∀ r. WithLunapark r LT.WindowHandle
111+getWindowHandle = liftLunapark $ GetWindowHandle id
112+
113+getWindowHandles ∷ ∀ r. WithLunapark r (Array LT.WindowHandle)
114+getWindowHandles = liftLunapark $ GetWindowHandles id
115+
116+closeWindow ∷ ∀ r. WithLunapark r Unit
117+closeWindow = liftLunapark $ CloseWindow unit
118+
119+switchToWindow ∷ ∀ r. LT.WindowHandle → WithLunapark r Unit
120+switchToWindow w = liftLunapark $ SwitchToWindow w unit
121+
122+switchToFrame ∷ ∀ r. LT.FrameId → WithLunapark r Unit
123+switchToFrame f = liftLunapark $ SwitchToFrame f unit
124+
125+switchToParentFrame ∷ ∀ r. WithLunapark r Unit
126+switchToParentFrame = liftLunapark $ SwitchToParentFrame unit
127+
128+getWindowRectangle ∷ ∀ r. WithLunapark r LT.Rectangle
129+getWindowRectangle = liftLunapark $ GetWindowRectangle id
130+
131+setWindowRectangle ∷ ∀ r. LT.Rectangle → WithLunapark r Unit
132+setWindowRectangle r = liftLunapark $ SetWindowRectangle r unit
133+
134+maximizeWindow ∷ ∀ r. WithLunapark r Unit
135+maximizeWindow = liftLunapark $ MaximizeWindow unit
136+
137+minimizeWindow ∷ ∀ r. WithLunapark r Unit
138+minimizeWindow = liftLunapark $ MinimizeWindow unit
139+
140+fullscreenWindow ∷ ∀ r. WithLunapark r Unit
141+fullscreenWindow = liftLunapark $ FullscreenWindow unit
142+
143+executeScript ∷ ∀ r. LT.Script → WithLunapark r J.Json
144+executeScript script = liftLunapark $ ExecuteScript script id
145+
146+executeScriptAsync ∷ ∀ r. LT.Script → WithLunapark r J.Json
147+executeScriptAsync script = liftLunapark $ ExecuteScriptAsync script id
148+
149+getAllCookies ∷ ∀ r. WithLunapark r (Array LT.Cookie)
150+getAllCookies = liftLunapark $ GetAllCookies id
151+
152+getCookie ∷ ∀ r. String → WithLunapark r LT.Cookie
153+getCookie name = liftLunapark $ GetCookie name id
154+
155+addCookie ∷ ∀ r. LT.Cookie → WithLunapark r Unit
156+addCookie cookie = liftLunapark $ AddCookie cookie unit
157+
158+deleteCookie ∷ ∀ r. String → WithLunapark r Unit
159+deleteCookie name = liftLunapark $ DeleteCookie name unit
160+
161+deleteAllCookies ∷ ∀ r. WithLunapark r Unit
162+deleteAllCookies = liftLunapark $ DeleteAllCookies unit
163+
164+dismissAlert ∷ ∀ r. WithLunapark r Unit
165+dismissAlert = liftLunapark $ DismissAlert unit
166+
167+acceptAlert ∷ ∀ r. WithLunapark r Unit
168+acceptAlert = liftLunapark $ AcceptAlert unit
169+
170+getAlertText ∷ ∀ r. WithLunapark r String
171+getAlertText = liftLunapark $ GetAlertText id
172+
173+sendAlertText ∷ ∀ r. String → WithLunapark r Unit
174+sendAlertText txt = liftLunapark $ SendAlertText txt unit
175+
176+screenshot ∷ ∀ r. String → WithLunapark r Unit
177+screenshot fp = liftLunapark $ Screenshot fp unit
178+
179+elementScreenshot ∷ ∀ r. LT.Element → String → WithLunapark r Unit
180+elementScreenshot el fp = liftLunapark $ OnElement el $ ScreenshotEl fp unit
181+
182+findElement ∷ ∀ r. LT.Locator → WithLunapark r LT.Element
183+findElement l = liftLunapark $ FindElement l id
184+
185+findElements ∷ ∀ r. LT.Locator → WithLunapark r (Array LT.Element)
186+findElements l = liftLunapark $ FindElements l id
187+
188+childElement ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r LT.Element
189+childElement el l = liftLunapark $ OnElement el $ ChildElement l id
190+
191+childElements ∷ ∀ r. LT.Element → LT.Locator → WithLunapark r (Array LT.Element)
192+childElements el l = liftLunapark $ OnElement el $ ChildElements l id
193+
194+isSelected ∷ ∀ r. LT.Element → WithLunapark r Boolean
195+isSelected el = liftLunapark $ OnElement el $ IsSelected id
196+
197+getAttribute ∷ ∀ r. LT.Element → String → WithLunapark r String
198+getAttribute el name = liftLunapark $ OnElement el $ GetAttribute name id
199+
200+getProperty ∷ ∀ r. LT.Element → String → WithLunapark r J.Json
201+getProperty el name = liftLunapark $ OnElement el $ GetProperty name id
202+
203+getCss ∷ ∀ r. LT.Element → String → WithLunapark r String
204+getCss el name = liftLunapark $ OnElement el $ GetCss name id
205+
206+getText ∷ ∀ r. LT.Element → WithLunapark r String
207+getText el = liftLunapark $ OnElement el $ GetText id
208+
209+getTagName ∷ ∀ r. LT.Element → WithLunapark r String
210+getTagName el = liftLunapark $ OnElement el $ GetTagName id
211+
212+getRectangle ∷ ∀ r. LT.Element → WithLunapark r LT.Rectangle
213+getRectangle el = liftLunapark $ OnElement el $ GetRectangle id
214+
215+isEnabled ∷ ∀ r. LT.Element → WithLunapark r Boolean
216+isEnabled el = liftLunapark $ OnElement el $ IsEnabled id
217+
218+clickElement ∷ ∀ r. LT.Element → WithLunapark r Unit
219+clickElement el = liftLunapark $ OnElement el $ ClickEl unit
220+
221+clearElement ∷ ∀ r. LT.Element → WithLunapark r Unit
222+clearElement el = liftLunapark $ OnElement el $ ClearEl unit
223+
224+sendKeysElement ∷ ∀ r. LT.Element → String → WithLunapark r Unit
225+sendKeysElement el txt = liftLunapark $ OnElement el $ SendKeysEl txt unit
226+
227+isDisplayed ∷ ∀ r. LT.Element → WithLunapark r Boolean
228+isDisplayed el = liftLunapark $ OnElement el $ IsDisplayed id
229+
230+submitElement ∷ ∀ r. LT.Element → WithLunapark r Unit
231+submitElement el = liftLunapark $ OnElement el $ Submit unit
232+
233+performActions ∷ ∀ r. LT.ActionRequest → WithLunapark r Unit
234+performActions req = liftLunapark $ PerformActions req unit
235+
236+releaseActions ∷ ∀ r. WithLunapark r Unit
237+releaseActions = liftLunapark $ ReleaseActions unit
src/Lunapark/Types.purs+3
@@ -1,3 +1,6 @@
1+-- | This module contains types for requests and response.
2+-- | Most of them are records with `α → Json` and `Json → Either String α` functions
3+-- | not newtypes with `Encode|DecodeJson` instances.
14module Lunapark.Types where
25
36import Prelude
src/Lunapark/Utils.pursnew file+34
@@ -0,0 +1,34 @@
1+module Lunapark.Utils where
2+
3+import Prelude
4+
5+import Control.Monad.Aff (Aff)
6+import Data.Bifunctor (lmap)
7+import Data.Either (Either)
8+import Lunapark.Error as LE
9+import Run as R
10+import Run.Except as RE
11+import Unsafe.Coerce (unsafeCoerce)
12+
13+liftAndRethrow
14+ ∷ ∀ e r ε ω
15+ . Aff e (Either ε ω)
16+ → R.Run (aff ∷ R.AFF e, except ∷ RE.EXCEPT ε|r) ω
17+liftAndRethrow a = do
18+ res ← R.liftAff a
19+ RE.rethrow res
20+
21+throwLeft
22+ ∷ ∀ r
23+ . Either String
24+ ~> R.Run (except ∷ RE.EXCEPT LE.Error|r)
25+throwLeft =
26+ RE.rethrow <<< lmap LE.unknownError
27+
28+-- Safe, since we actually want handler and result have same rows not, remove except
29+catch
30+ ∷ ∀ e r a
31+ . R.Run (except ∷ RE.EXCEPT e|r) a
32+ → (e → R.Run (except ∷ RE.EXCEPT e|r) a)
33+ → R.Run (except ∷ RE.EXCEPT e|r) a
34+catch = unsafeCoerce $ flip RE.catch
src/Main.pursdeleted−32
@@ -1,32 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−import Control.Monad.Aff as Aff
6−import Control.Monad.Eff (Eff)
7−import Data.Newtype (wrap)
8−import Data.Traversable (for_)
9−import Lunapark.API as LA
10−import Lunapark.Types as LT
11−import Run as R
12−import Run.Except as RE
13−
14−import Debug.Trace as DT
15−
16−main ∷ Eff _ Unit
17−main = void $ Aff.launchAff do
18− eiInterpret ← LA.init "http://localhost:4444/wd/hub" { alwaysMatch: [], firstMatch: [ [ LT.BrowserName LT.Chrome ] ] }
19− for_ eiInterpret \interpret → do
20− R.runBaseAff' $ RE.runExcept $ interpret do
21− st ← LA.status
22− DT.traceAnyA "status"
23− DT.traceAnyA st
24− ts ← LA.getTimeouts
25− DT.traceAnyA "timeouts"
26− DT.traceAnyA ts
27− LA.setTimeouts ts{ pageLoad = wrap 10.0 }
28− ts' ← LA.getTimeouts
29− DT.traceAnyA "timeouts'"
30− DT.traceAnyA ts'
31− LA.setTimeouts ts
32− LA.quit