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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Webdriver(serveWebdriver) where
import Happstack.Lite
import Control.Concurrent.MVar
import Data.Aeson
import Data.Text (Text)
import GHC.Generics
import Data.ByteString.Lazy (ByteString)
import qualified Data.HashMap.Strict as M
import Data.UUID as ID
import Data.UUID.V4
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe, isJust)
import qualified Network.URI as URI
import qualified Network.URI.Fetch as URI
import Capabilities (processCaps)
import JSON
import qualified Internal as WD
import qualified Internal.Load as WD
serveWebdriver :: WD.Sessions -> ServerPart Response
serveWebdriver sessions = do
msum [
dir "status" serveStatus,
dir "session" $ postSession sessions,
dir "session" $ path $ serveSession sessions,
nullDir >> ok (toResponse ("This is a WebDriver endpoint. Please copy the URL to hand to Selenium." :: Text))
]
serveSession :: WD.Sessions -> String -> ServerPart Response
serveSession sessions = WD.withSession fail (\uuid session -> msum [
delSession sessions uuid,
dir "timeouts" $ getTimeout session,
dir "timeouts" $ setTimeout session
]) sessions
where
fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ (
"Session " ++ uuid' ++ " was not found in active sessions")
| otherwise = errJSON 404 "invalid session ID" $ ("UUID " ++ uuid' ++ " is not a valid UUID")
data Status = Status {ready :: Bool, message :: Text} deriving Generic
instance ToJSON Status
serveStatus = okJSON $ Status True "Always ready to open new sessions"
data NewSession = NewSession {sessionId :: UUID, capabilities :: Object} deriving Generic
instance ToJSON NewSession
postSession sessions = do
method POST
nullDir
caps' <- getJSON
case processCaps caps' of
Just caps -> do
(uuid, _) <- liftIO $ WD.createSession sessions caps
okJSON $ NewSession uuid caps
Nothing -> errJSON 500 "session not created" "Invalid capabilities specified!"
delSession sessions uuid = do
method DELETE
nullDir
liftIO $ WD.delSession uuid sessions
ok $ toResponse ()
getTimeout session = do
method GET
nullDir
session' <- liftIO $ readMVar session
okJSON $ WD.timeouts session'
setTimeout session = do
method POST
nullDir
update' <- getJSON
session' <- liftIO $ readMVar session
case update' of
Just (Object update) | Object current <- toJSON $ WD.timeouts session',
Success new <- fromJSON $ toJSON $ M.union update current -> do
liftIO $ swapMVar session session' {WD.timeouts = new}
ok $ toResponse ()
_ -> errJSON 400 "invalid argument" "Failed to parse JSON input"
data NavigateTo = NavigateTo { url :: String } deriving Generic
instance FromJSON NavigateTo
navigateTo session = do
method POST
nullDir
target' <- getJSON
case target' of
Just target | Just url' <- URI.parseAbsoluteURI target -> do
liftIO $ WD.load session url'
ok $ toResponse ()
Just target -> errJSON 400 "invalid argument" (target ++ " is not an absolute URL")
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input"