~alcinnz/amphiarao

ref: d647a0fac39408d9f45a4bbb2a9f1c095ab4cfb4 amphiarao/src/Internal/Load.hs -rw-r--r-- 1.8 KiB
d647a0fa — Adrian Cochrane Add noop stubs to control non-existant windows. 3 years ago
                                                                                
afb3d55d Adrian Cochrane
d4c10f89 Adrian Cochrane
afb3d55d Adrian Cochrane
d4c10f89 Adrian Cochrane
afb3d55d Adrian Cochrane
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
module Internal.Load(load, load', back, next, parseAbsoluteURI) where

import Internal

import Control.Concurrent.MVar
import System.Timeout (timeout)
import Control.Monad.IO.Class

import Data.Aeson
import Data.Text (Text, pack)
import GHC.Generics

import Data.Maybe (fromMaybe)

import Network.URI as URI
import Network.URI.Fetch as URI

mime = words "text/html text/xml application/xml application/xhtml+xml text/plain"

load' :: Internal.Session -> URI -> IO ()
load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do
    (redirected, _, _) <- fetchURL' (loader session') mime uri
    return $ session' { currentURL = redirected}

maybeTimeout :: Session' -> URI -> IO Session' -> IO Session'
maybeTimeout session uri act | currentURL session /= uri, Just delay <- pageLoad $ timeouts session =
    -- WebDriver deals in terms of milliseconds, I think?, Haskell deals in terms of microseconds.
    fromMaybe session <$> timeout (delay * 1000) act
maybeTimeout _ _ act = act

---

load :: Internal.Session -> URI -> IO ()
load session uri = do
    modifyMVar_ session $ return . inner
    load' session uri
  where
    inner session'@Session {backStack = backStack', currentURL = currentURL' } =
        session' { backStack = currentURL' : backStack' }

back :: Internal.Session -> IO ()
back session = do
    uri <- modifyMVar session $ return . inner
    load' session uri
  where
    inner session'@Session { backStack = b:bs, currentURL = n, nextStack = ns } =
        (session' { backStack = bs, nextStack = n:ns }, b)

next :: Internal.Session -> IO ()
next session = do
    uri <- modifyMVar session $ return . inner
    load' session uri
  where
    inner session'@Session { backStack = bs, currentURL = b, nextStack = n:ns } =
        (session' { backStack = b:bs, nextStack = ns }, n)