M amphiarao.cabal => amphiarao.cabal +6 -3
@@ 54,15 54,18 @@ executable amphiarao
main-is: Main.hs
-- Modules included in this executable, other than Main.
- -- other-modules:
+ other-modules: Webdriver, Capabilities, JSON, Messages, Internal, Internal.Load,
+ UI.Templates, UI.Search
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.10, happstack-lite >=7.3.7 && <7.4, happstack-server,
- aeson >= 1.5.0 && <1.6, text, bytestring,
- containers >=0.5 && <0.7, uuid >=1.3 && <1.4
+ aeson >= 1.5.0 && <1.6, text, bytestring, unordered-containers, vector,
+ containers >=0.5 && <0.7, uuid >=1.3 && <1.4,
+ blaze-html,
+ hurl >= 2.1 && <3, network-uri
-- Directories containing source files.
hs-source-dirs: src
A src/Capabilities.hs => src/Capabilities.hs +59 -0
@@ 0,0 1,59 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+module Capabilities(processCaps) where
+
+import Data.Aeson
+import Data.Text (Text, pack)
+import qualified Data.HashMap.Strict as M
+import qualified Data.Vector as V
+
+import Data.Maybe (isJust, mapMaybe, fromMaybe)
+import Internal (Timeouts(..))
+
+processCaps :: Maybe Value -> Maybe Object
+processCaps caps
+ | Just (required, fallbacks) <- decodeCaps caps, isJust $ validateCap required =
+ foldl mergeCaps (Just required) $ mapMaybe validateCap fallbacks
+processCaps _ = Nothing
+
+-- Manual decode, to ensure WebDriver specs are followed.
+decodeCaps :: Maybe Value -> Maybe (Object, [Object])
+decodeCaps (Just (Object obj))
+ | Just (Object caps) <- "capabilities" `M.lookup` obj,
+ required <- "alwaysMatch" `M.lookup` caps, fallbacks <- "firstMatch" `M.lookup` caps,
+ fromMaybe True (isObj <$> required) =
+ let required' = case required of {
+ Just (Object o) -> o;
+ _ -> nilCap
+ } in case fallbacks of
+ Just (Array fallbacks') | all isObj fallbacks' ->
+ Just (required', [f | Object f <- V.toList fallbacks'])
+ Nothing -> Just (required', [nilCap])
+ _ -> Nothing
+ where
+ isObj (Object _) = True
+ isObj _ = False
+ nilCap = M.empty
+decodeCaps _ = Nothing
+
+validateCap :: Object -> Maybe Object
+validateCap cap
+ | and [isJust $ inner k v | (k, v) <- M.toList cap, v /= Null] = Just $ M.mapMaybeWithKey inner cap
+ | otherwise = Nothing
+ where
+ inner _ Null = Nothing
+ inner "acceptInsecureCertificates" v@(Bool _) = Just v -- What's the behavior here?
+ inner "browserName" v@(String "rhapsode") = Just v
+ inner "browserVersion" v@(String "5") = Just v
+ inner "browserVersion" v@(String "4") = Just v
+ inner "browserVersion" v@(String "3") = Just v
+ inner "platformName" v@(String _) = Just v -- Rhapsode's very cross-platform.
+ inner "pageLoadStrategy" v@(String v') | v' `elem` ["none", "eager", "normal"] = Just v -- Noop
+ -- I don't support "proxy" yet.
+ inner "timeouts" v | Success Timeouts {} <- fromJSON v = Just v
+ inner "unhandledPromptBehavior" v@(String v')
+ | v' `elem` ["dissmiss", "accept", "dismiss and accept", "accept and notify", "ignore"] = Just v -- Noop
+ inner _ _ = Nothing
+
+mergeCaps :: Maybe Object -> Object -> Maybe Object
+mergeCaps (Just primary) secondary | M.null $ M.intersection primary secondary =
+ Just $ M.union primary secondary
A src/Internal.hs => src/Internal.hs +68 -0
@@ 0,0 1,68 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
+module Internal(Session(..), Session'(..), Sessions(..),
+ initSessions, createSession, delSession, getSession, withSession,
+ Timeouts(..)) where
+
+import qualified Data.HashMap.Strict as M
+import Data.UUID as ID
+import Data.UUID.V4 as ID
+import Control.Concurrent.MVar
+
+import Control.Monad.IO.Class
+
+import Data.Aeson
+import Data.Text (Text, pack)
+import GHC.Generics
+
+import qualified Network.URI as URI
+import qualified Network.URI.Fetch as URI
+
+type Sessions = MVar (M.HashMap UUID Session)
+type Session = MVar Session'
+data Session' = Session {
+ timeouts :: Timeouts,
+ loader :: URI.Session,
+ currentURL :: URI.URI
+ }
+
+initSessions :: IO Sessions
+initSessions = newMVar M.empty
+
+createSession :: Sessions -> Object -> IO (UUID, Session)
+createSession sessions caps = do
+ uuid <- ID.nextRandom
+ loader' <- URI.newSession
+ let session = Session {
+ timeouts = case "timeouts" `M.lookup` caps of
+ Just t | Success t' <- fromJSON t -> t'
+ _ -> Timeouts Nothing Nothing Nothing,
+ loader = loader',
+ currentURL = URI.nullURI
+ }
+ session' <- newMVar session
+ modifyMVar_ sessions (return . M.insert uuid session')
+ return (uuid, session')
+
+delSession :: UUID -> Sessions -> IO ()
+delSession uuid sessions = modifyMVar_ sessions (return . M.delete uuid)
+
+getSession :: String -> Sessions -> IO (Maybe (UUID, Session))
+getSession uuid' sessions' = withMVar sessions' (return . getSession' (ID.fromString uuid'))
+getSession' :: Maybe UUID -> M.HashMap UUID Session -> Maybe (UUID, Session)
+getSession' (Just uuid) sessions | Just session <- M.lookup uuid sessions = Just (uuid, session)
+getSession' _ _ = Nothing
+
+withSession :: MonadIO m => (String -> m a) -> (UUID -> Session -> m a) -> Sessions -> String -> m a
+withSession fail pass sessions' uuid' = do
+ ret <- liftIO $ getSession uuid' sessions'
+ case ret of
+ Just (uuid, session) -> pass uuid session
+ Nothing -> fail uuid'
+
+data Timeouts = Timeouts {
+ script :: Maybe Int, -- Noop
+ pageLoad :: Maybe Int,
+ implicit :: Maybe Int -- Noop?
+ } deriving Generic
+instance FromJSON Timeouts
+instance ToJSON Timeouts
A src/Internal/Load.hs => src/Internal/Load.hs +29 -0
@@ 0,0 1,29 @@
+module Internal.Load(load, 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
A src/JSON.hs => src/JSON.hs +45 -0
@@ 0,0 1,45 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
+module JSON(getJSON, okJSON, errJSON) where
+
+import Happstack.Lite
+import Happstack.Server.Types (unBody, takeRequestBody)
+import Happstack.Server (askRq, resp)
+
+import Data.Aeson
+import Data.Text (Text)
+import GHC.Generics
+import Data.ByteString.Lazy (ByteString)
+
+import Control.Monad.IO.Class (liftIO)
+
+getBody :: ServerPart ByteString
+getBody = do
+ req <- askRq
+ body <- liftIO $ takeRequestBody req
+ case body of
+ Just rqbody -> return . unBody $ rqbody
+ Nothing -> return ""
+
+getJSON :: FromJSON x => ServerPart (Maybe x)
+getJSON = decode <$> getBody
+
+okJSON :: ToJSON x => x -> ServerPart Response
+okJSON x = do
+ setHeaderM "Content-Type" "application/json"
+ ok $ toResponse $ encode x
+
+data WDError' = WDError' {
+ value :: WDError
+ } deriving Generic
+instance ToJSON WDError'
+data WDError = WDError {
+ error :: Text,
+ message :: String,
+ stacktrace :: Text -- Noop
+ } deriving Generic
+instance ToJSON WDError
+
+errJSON :: Int -> Text -> String -> ServerPart Response
+errJSON code name message = do
+ setHeaderM "Content-Type" "application/json"
+ resp code $ toResponse $ encode $ WDError' $ WDError name message ""
M src/Main.hs => src/Main.hs +117 -7
@@ 2,21 2,131 @@
module Main where
import Happstack.Lite
+import Happstack.Server.RqData
import Control.Concurrent.MVar
-import qualified Data.Map.Strict as M
+import Data.HashMap.Strict as M
+
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import Text.Blaze.Html (text, string)
+import qualified Data.Text as Txt
import Webdriver
-import Data.UUID
+import Data.UUID as ID
+
+import Messages
+import Happstack.Server.I18N
+
+import Internal
+import Internal.Load as Load
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad (forM)
+
+import qualified UI.Templates as Tpl
+import qualified UI.Search as Q
main :: IO ()
main = do
- sessions <- newMVar emptySessions
+ sessions <- initSessions
serve Nothing $ msum [
dir "webdriver" $ dir "v1" $ serveWebdriver sessions,
- serveHome
+ postHome sessions,
+ serveHome,
+ dir "preview-prompt" servePreviewPrompt,
+ dir "close" $ path $ deleteSession sessions,
+ path $ serveSession sessions
+ ]
+
+serveHome :: ServerPart Response
+serveHome = do
+ nullDir
+ method GET
+ Tpl.page ok ["Amphiarao"] $ \langs -> do
+ l langs AmphiaraoIntro
+ Tpl.sessionForm langs
+
+postHome sessions = do
+ nullDir
+ method POST
+ (uuid, session) <- liftIO $ createSession sessions M.empty
+ target <- looks "target"
+ -- Not much point of a blank session, so allow loading here.
+ case target of
+ (target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load session url
+ _ -> return ()
+ seeOther ('/' : ID.toString uuid) $ toResponse ()
+
+deleteSession sessions uuid = do
+ nullDir
+ method POST
+ case ID.fromString uuid of
+ Just id -> liftIO $ delSession id sessions
+ Nothing -> return ()
+ seeOther ['/'] $ toResponse ()
+
+servePreviewPrompt = do
+ nullDir
+ method GET
+ Tpl.page ok ["?", "Amphiarao"] $ \langs -> H.p $ l langs PromptPreview
+
+serveSession :: Sessions -> String -> ServerPart Response
+serveSession = withSession session404 $ \uuid session -> msum [
+ sessionHome uuid session,
+ dir "timeout" $ setTimeout uuid session,
+ dir "search" $ searchSession uuid session,
+ dir "nav" $ msum [
+ dir "load" $ loadPage uuid session
+ ]
]
-emptySessions :: M.Map UUID WDSession
-emptySessions = M.empty
+sessionHome uuid session = do
+ nullDir
+ method GET
+
+ let uuid' = ID.toString uuid
+ Tpl.inspector ok "UUID" session uuid $ \langs -> H.h1 $ string uuid'
+
+session404 uuid = do
+ Tpl.page notFound ["404", "Amphiarao"] $ \langs -> do
+ H.h1 $ l langs SessionNotFound
+ Tpl.sessionForm langs
+
+setTimeout uuid session = do
+ nullDir
+ method POST
+ timeout <- lookRead "pageLoad"
+ let inner s = return $ s {timeouts = (timeouts s) {pageLoad = Just timeout}}
+ liftIO $ modifyMVar_ session inner
+ seeOther ('/':ID.toString uuid) $ toResponse ()
+
+searchSession uuid session = do
+ nullDir
+ method GET
+ q <- look "q"
+ session' <- liftIO $ readMVar session
+ let results = [(header, labelEmpty $ engine q session') | (header, engine) <- Q.engines]
+ Tpl.inspector ok (Txt.pack ('🔎':q)) session uuid $ \langs -> H.main $ do
+ H.aside $ do
+ H.form $ do
+ H.input H.! A.type_ "search" H.! A.name "q" H.! A.value (H.stringValue q)
+ H.dl $ do
+ forM results $ \(header, results') -> do
+ H.dt $ header langs
+ forM results' $ \result -> H.dd $ result langs
+ return ()
+ return ()
+ H.section $ do
+ H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ ""
+ where
+ labelEmpty [] = [\langs -> l langs NoResults]
+ labelEmpty x = x
-serveHome = ok $ toResponse ("Hello, world!" :: String)
+loadPage uuid session = do
+ nullDir
+ method POST
+ target <- look "url"
+ case Load.parseAbsoluteURI target of
+ Just url -> do
+ liftIO $ Load.load session url
+ seeOther ('/':ID.toString uuid) $ toResponse ()
+ Nothing -> Tpl.inspector ok "400" session uuid $ \langs -> l langs ErrURL
A src/Messages.hs => src/Messages.hs +43 -0
@@ 0,0 1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Messages(l, Message(..)) where
+
+import Text.Blaze.Html5 as H
+import Text.Blaze.Html5.Attributes as A
+import Text.Blaze.Html
+import Data.Text (Text)
+
+data Message =
+ AmphiaraoIntro |
+ CreateSession |
+ CloseSession |
+ LoadTimeout |
+ SessionNotFound |
+ NoResults |
+ PromptPreview |
+ ErrURL deriving Show
+
+l :: [Text] -> Message -> Html
+---- Begin localizations
+l ("en":_) AmphiaraoIntro = do
+ h1 "Amphiarao webpage debugger for Rhapsode"
+ p $ do
+ text "Amphiarao lets you analyze how webpages are parsed & styled in "
+ a ! href "https://rhapsode.adrian.geek.nz/" $ "Rhapsode"
+ text ", either programmatically via "
+ a ! href "https://www.selenium.dev/" $ "Selenium"
+ text " (using "
+ a ! href "/webdriver/v1/" $ "this WebDriver endpoint"
+ text ") or manually via this web UI which can be viewed in any web browser including Rhapsode. "
+ p "Amphiarao is a locally-run webservice implemented using the same underlying libraries as Rhapsode."
+l ("en":_) CreateSession = "Open new test session"
+l ("en":_) LoadTimeout = "Load Timeout"
+l ("en":_) CloseSession = "Close Session"
+l ("en":_) SessionNotFound = "Session Not Found"
+l ("en":_) NoResults = em "No Results"
+l ("en":_) PromptPreview = em "Click a search result to preview it here"
+l ("en":_) ErrURL = do
+ h1 "Invalid Link!"
+ p "The provided URL was not absolute."
+---- End localizations
+l (_:langs) msg = l langs msg
+l [] msg = string $ show msg
A src/UI/Search.hs => src/UI/Search.hs +29 -0
@@ 0,0 1,29 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+module UI.Search(engines) where
+
+import Text.Blaze.Html5 as H
+import Text.Blaze.Html5.Attributes as A
+import Text.Blaze.Html
+import Data.Text as Txt
+
+import Internal
+
+import Network.URI (parseAbsoluteURI)
+
+engines :: [(
+ [Text] -> Html,
+ String -> Session' -> [[Text] -> Html]
+ )]
+engines = [
+ (const "URL", offerToLoad)
+ ]
+
+offerToLoad q _ | Just _ <- parseAbsoluteURI q = [const $ do
+ result q q
+ H.form ! action "nav/load" ! method "POST" $ do
+ input ! type_ "hidden" ! name "url" ! value (stringValue q)
+ button ! type_ "submit" ! class_ "disclosure" $ disclosure
+ ]
+
+result href' label = a ! href (stringValue href') ! target "preview" $ string label
+disclosure = "⤷"
A src/UI/Templates.hs => src/UI/Templates.hs +51 -0
@@ 0,0 1,51 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+module UI.Templates(page, inspector, sessionForm) where
+
+import Happstack.Lite
+import Text.Blaze.Html5 as H
+import Text.Blaze.Html5.Attributes as A
+import Text.Blaze.Html
+import Data.Text as Txt
+
+import Internal
+import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
+import Data.UUID as ID
+
+import Messages
+import Happstack.Server.I18N
+
+page :: (Response -> ServerPart Response) -> [Text] -> ([Text] -> Html) -> ServerPart Response
+page return' title body' = do
+ langs <- bestLanguage <$> acceptLanguage
+ return' $ toResponse $ html $ do
+ H.head $ do
+ H.title $ text $ intercalate " — " title
+ body $ body' langs
+
+inspector :: (Response -> ServerPart Response) -> Text -> Session -> UUID -> ([Text] -> Html) -> ServerPart Response
+inspector return' title session uuid body' = do
+ session' <- liftIO $ readMVar session
+ let uuid' = ID.toString uuid
+ let timeout = H.stringValue $ show $ pageLoad $ timeouts session'
+ page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] $ \langs -> do
+ header $ do
+ H.form ! action' ["/", uuid', "/search"] $ do
+ input ! type_ "search" ! name "q" ! placeholder "Search..."
+ body' langs
+ footer $ do
+ H.form ! action' ["/close/", uuid'] ! A.method "POST" $ do
+ button ! type_ "submit" $ l langs CloseSession
+ hr
+ H.form ! action' ["/", uuid', "/timeout"] ! A.method "POST" $ p $ do
+ H.label $ do
+ l langs LoadTimeout
+ input ! type_ "number" ! name "pageLoad" ! value timeout
+ text "ms"
+
+ where
+ action' = A.action . H.stringValue . Prelude.concat
+
+sessionForm langs = H.form ! A.method "POST" ! action "/" $ do
+ input ! type_ "url" ! name "target" ! placeholder "URL to debug"
+ button ! type_ "submit" $ l langs CreateSession
M src/Webdriver.hs => src/Webdriver.hs +74 -38
@@ 1,60 1,96 @@
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
-module Webdriver(serveWebdriver, WDSession(..)) where
+module Webdriver(serveWebdriver) where
import Happstack.Lite
-import Happstack.Server.Types (unBody, takeRequestBody)
-import Happstack.Server (askRq)
import Control.Concurrent.MVar
import Data.Aeson
import Data.Text (Text)
import GHC.Generics
import Data.ByteString.Lazy (ByteString)
-import qualified Data.Map.Strict as M
-import Data.UUID
+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)
+import Data.Maybe (fromMaybe, isJust)
-data WDSession = WDSession -- TODO: Add fields
+import qualified Network.URI as URI
+import qualified Network.URI.Fetch as URI
-serveWebdriver :: MVar (M.Map UUID WDSession) -> ServerPart Response
-serveWebdriver sessions = msum [
- dir "status" serveStatus,
- dir "session" $ postSession sessions
- ]
+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 :: Value} deriving Generic
+data NewSession = NewSession {sessionId :: UUID, capabilities :: Object} deriving Generic
instance ToJSON NewSession
postSession sessions = do
method POST
- caps <- fromMaybe Null <$> getJSON
- -- FIXME: Validate provided capabilities.
- uuid <- liftIO nextRandom
- let session = WDSession
- liftIO $ modifyMVar_ sessions (return . M.insert uuid session)
- okJSON $ NewSession uuid caps
-
---------
----- Utils
---------
-getBody :: ServerPart ByteString
-getBody = do
- req <- askRq
- body <- liftIO $ takeRequestBody req
- case body of
- Just rqbody -> return . unBody $ rqbody
- Nothing -> return ""
-
-getJSON :: FromJSON x => ServerPart (Maybe x)
-getJSON = decode <$> getBody
-
-okJSON :: ToJSON x => x -> ServerPart Response
-okJSON x = do
- setHeaderM "Content-Type" "application/json"
- ok $ toResponse $ encode x
+ 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"